#!/usr/bin/clisp -ansi -norc -q -E iso-8859-1
;; -*- mode:lisp;coding:iso-8859-1 -*-
(setf *print-right-margin* 80
      *print-pretty* t
      *print-case* :upcase)

(defun split-string (string &optional (separators " ") (remove-empty nil))
  "
STRING:         A sequence.

SEPARATOR:      A sequence.

RETURN:         A list of subsequence of STRING, split upon any element of SEPARATORS.
                Separators are compared to elements of the STRING with EQL.

NOTE:           It's actually a simple split-sequence now.

EXAMPLES:       (split-string '(1 2 0 3 4 5 0 6 7 8 0 9) '(0))
                --> ((1 2) (3 4 5) (6 7 8) (9))
                (split-string #(1 2 0 3 4 5 0 6 7 8 0 9) #(0))
                --> (#(1 2) #(3 4 5) #(6 7 8) #(9))
                (split-string \"1 2 0 3 4 5 0 6 7 8\" '(#\space #\0))
                --> (\"1\" \"2\" \"\" \"\" \"3\" \"4\" \"5\" \"\" \"\" \"6\" \"7\" \"8\")
"
  (loop
    :with strlen = (length string)
    :for position = 0 :then (1+ nextpos)
    :for nextpos = (position-if (lambda (e) (find e separators)) string :start position)
    :unless (and remove-empty
                 (or (and (= position strlen) (null nextpos ))
                     (eql position nextpos)))
    :collect (subseq string position nextpos)
    :while (and nextpos (< position strlen))))


(defun maptree (fun &rest trees)
  "
DO:     Calls FUN on each non-null atom of the TREES.
PRE:    The trees in TREES must be congruent, or else the result is
        pruned like the smallest tree.
RETURN: A tree congruent to the TREES, each node being the result of
        FUN (it may be a subtree).
"
  (cond ((null trees) nil)
        ((every (function null)  trees) nil)
        ((every (function atom)  trees) (apply fun trees))
        ((every (function consp) trees)
         (cons (apply (function maptree) fun (mapcar (function car) trees))
               (apply (function maptree) fun (mapcar (function cdr) trees))))
        (t nil)))



(defpackage "CFFI"
  (:export
   "*DARWIN-FRAMEWORK-DIRECTORIES*" "*DEFAULT-FOREIGN-ENCODING*"
   "*FOREIGN-LIBRARY-DIRECTORIES*"  "CALLBACK" "CLOSE-FOREIGN-LIBRARY"
   "CONVERT-FROM-FOREIGN" "CONVERT-TO-FOREIGN" "DEFBITFIELD"
   "DEFCALLBACK" "DEFCENUM" "DEFCFUN" "DEFCSTRUCT" "DEFCTYPE"
   "DEFCUNION" "DEFCVAR" "DEFINE-C-STRUCT-WRAPPER"
   "DEFINE-FOREIGN-LIBRARY" "DEFINE-FOREIGN-TYPE"
   "DEFINE-PARSE-METHOD" "EXPAND-FROM-FOREIGN"  "EXPAND-TO-FOREIGN"
   "EXPAND-TO-FOREIGN-DYN" "FOREIGN-ALLOC"
   "FOREIGN-BITFIELD-SYMBOL-LIST"  "FOREIGN-BITFIELD-SYMBOLS"
   "FOREIGN-BITFIELD-VALUE" "FOREIGN-ENUM-KEYWORD"
   "FOREIGN-ENUM-KEYWORD-LIST" "FOREIGN-ENUM-VALUE" "FOREIGN-FREE"
   "FOREIGN-FUNCALL"  "FOREIGN-FUNCALL-POINTER" "FOREIGN-LIBRARY"
   "FOREIGN-LIBRARY-LOADED-P" "FOREIGN-LIBRARY-NAME"
   "FOREIGN-LIBRARY-PATHNAME" "FOREIGN-LIBRARY-TYPE" "FOREIGN-POINTER"
   "FOREIGN-SLOT-NAMES"  "FOREIGN-SLOT-OFFSET" "FOREIGN-SLOT-POINTER"
   "FOREIGN-SLOT-VALUE" "FOREIGN-STRING-ALLOC"  "FOREIGN-STRING-FREE"
   "FOREIGN-STRING-TO-LISP" "FOREIGN-SYMBOL-POINTER"
   "FOREIGN-TYPE-ALIGNMENT"  "FOREIGN-TYPE-SIZE"
   "FREE-CONVERTED-OBJECT" "FREE-TRANSLATED-OBJECT" "GET-CALLBACK"
   "GET-VAR-POINTER"  "INC-POINTER" "INCF-POINTER"
   "LISP-STRING-TO-FOREIGN" "LIST-FOREIGN-LIBRARIES"
   "LOAD-FOREIGN-LIBRARY"  "LOAD-FOREIGN-LIBRARY-ERROR" "MAKE-POINTER"
   "MAKE-SHAREABLE-BYTE-VECTOR" "MEM-AREF" "MEM-REF"  "NULL-POINTER"
   "NULL-POINTER-P" "POINTER-ADDRESS" "POINTER-EQ" "POINTERP"
   "RELOAD-FOREIGN-LIBRARIES"  "TRANSLATE-CAMELCASE-NAME"
   "TRANSLATE-FROM-FOREIGN" "TRANSLATE-NAME-FROM-FOREIGN"
   "TRANSLATE-NAME-TO-FOREIGN" "TRANSLATE-TO-FOREIGN"
   "TRANSLATE-UNDERSCORE-SEPARATED-NAME"  "USE-FOREIGN-LIBRARY"
   "WITH-FOREIGN-OBJECT" "WITH-FOREIGN-OBJECTS" "WITH-FOREIGN-POINTER"
   "WITH-FOREIGN-POINTER-AS-STRING" "WITH-FOREIGN-SLOTS"
   "WITH-FOREIGN-STRING" "WITH-FOREIGN-STRINGS"
   "WITH-POINTER-TO-VECTOR-DATA" ))


(defparameter *clang-package-name* "COM.OGAMITA.CLANG")
(make-package "COM.OGAMITA.CLANG" :use '())




(defparameter *lispified* (make-hash-table))




(defun lispify-name (csym)
  (flet ((lispify-name (cname)
           (with-output-to-string (*standard-output*)
             (loop
               :with state = :out
               :for ch :across cname
               :do (if (alpha-char-p ch)
                     (ecase state
                       (:out
                        (setf state (cond
                                      ((upper-case-p ch) :upper)
                                      ((lower-case-p ch) :lower)
                                      (t                 state)))
                        (princ (string-upcase ch)))
                       (:upper
                        (when (lower-case-p ch)
                          (setf state :lower))
                        (princ (string-upcase ch)))
                       (:lower
                        (when (upper-case-p ch)
                          (setf state :upper)
                          (princ "-"))
                        (princ (string-upcase ch))))
                     (progn
                       (setf state :out)
                       (case ch
                         ((#\_)     (princ "-"))
                         (otherwise (princ ch)))))))))
    (let ((cname (symbol-name csym)))
      (cond
        ((and (< 6 (length cname))
              (string= "clang_" cname :end2 6))
         (lispify-name (subseq cname 6)))
        ((and (< 2 (length cname))
              (string= "CX" cname :end2 2))
         (lispify-name (subseq cname 2)))
        (t
         (lispify-name cname))))))


(defun lispify-clang-symbol (symbol)
  (or (gethash symbol *lispified*)
      (setf (gethash symbol *lispified*)
            (intern (lispify-name symbol) *clang-package-name*))))



(defparameter *sexps*
  (unwind-protect
      (loop
        :with eof = '#:eof
        :initially (setf (readtable-case *readtable*) :invert)
        :for sexp = (read *standard-input* nil eof)
        :until (eq sexp eof)
        :collect sexp)
    (setf (readtable-case *readtable*) :upcase)))



;; lispify symbols
;; export symbols from com.ogamita.clang

(defun lispify (atom)
  (gethash atom *lispified* atom))


(defun lispify-sexp-1 (sexp)
  (if (atom sexp)
    sexp
    (case (first sexp)
      ((cffi:defcfun)
       (destructuring-bind (op (cname lisp-name) res-type &rest parameters) sexp
         `(,op (,cname ,(lispify-clang-symbol lisp-name)) ,(lispify res-type)
               ,@(mapcar (lambda (param)
                             `(,(first param) ,(lispify (second param))))
                         parameters))))
      ((cl:defconstant)
       (destructuring-bind (op name expr) sexp
         `(,op ,(lispify-clang-symbol name) ,(maptree (function lispify) expr))))
      ((cffi:defcenum)
       (destructuring-bind (op name &rest constants) sexp
         `(,op ,(lispify-clang-symbol name)
               ,@(mapcar (lambda (constant)
                             (if (atom constant)
                               (intern (lispify-name constant) "KEYWORD")
                               `(,(intern (lispify-name (first constant)) "KEYWORD")
                                  ,(second constant))))
                         constants))))
      ((cffi:defctype)
       (destructuring-bind (op name ctype) sexp
         `(,op ,(lispify-clang-symbol name) ,(lispify ctype))))
      ((cffi:defcstruct)
       (destructuring-bind (op name &rest slots) sexp
         `(,op ,(lispify-clang-symbol name)
               ,@(mapcar (lambda (slot)
                             `(,(lispify-clang-symbol (first slot))
                               ,(lispify (second slot))))
                         slots))))
      (otherwise
       sexp))))


(defun lispify-sexp-2 (sexp)
  (if (atom sexp)
    (lispify sexp)
    (case (first sexp)
      ((cl:defconstant) sexp)
      ((cffi:defcfun) sexp)
      ((cffi:defcenum) sexp)
      ((cffi:defctype) sexp)
      ((cffi:defcstruct) sexp)
      (otherwise
       (maptree (function lispify) sexp)))))


(setf *sexps* (mapcar (function lispify-sexp-1) *sexps*))
(setf *sexps* (mapcar (function lispify-sexp-2) *sexps*))

(defparameter *clang-exports*  (let ((syms '()))
                                 (do-symbols (symbol *clang-package-name* syms)
                                   (push symbol syms))))
(export *clang-exports* *clang-package-name*)

(format t ";;;; -*- mode:lisp; coding:utf-8 -*-~2%")

(pprint
 `(defpackage ,*clang-package-name*
    (:use)
    (:export ,@(mapcar (function symbol-name) *clang-exports*))))

(dolist (sexp *sexps*)
  (pprint sexp))

(ext:exit 0)


#|
sed	-e 1i\\ -e '(in-package "COM.OGAMITA.CLANG")' \
	-e 's/(cl:defconstant CINDEX_VERSION .*)/(cl:defconstant CINDEX_VERSION (cl:+ (cl:* CINDEX_VERSION_MAJOR 10000) (cl:* CINDEX_VERSION_MINOR 1)))/' \
	-e 's/#\.(cl:logior CXGlobalOpt_ThreadBackgroundPriorityForIndexing CXGlobalOpt_ThreadBackgroundPriorityForEditing)/3/' \
|#
ViewGit