path: root/cmamut.lisp

(in-package #:cmamut)

(defparameter +target-package+ (gensym))

; TODO: Create a C parser so I don't rely on c2ffi.
; TODO: Process the header files directly in memory.
(defun get-raw-spec (filename search-directories)
  (sb-ext:run-program "/usr/local/bin/c2ffi"
                      (list filename
                            "--macro-file" "defines.h"
                            "--with-macro-defs"
                            "--output" "spec.json"))
  (let ((tmp (make-string-output-stream)))
    (with-open-file (in "defines.h")
      (loop :for ln = (read-line in nil)
            :while ln :do
            (when (some (lambda (path) (search path ln)) search-directories)
              (format tmp "~a~&~a~&" (read-line in) (read-line in)))))
    (with-open-file (out "defines.h" :direction :output :if-exists :supersede)
      (format out "~a" (get-output-stream-string tmp))))
  (sb-ext:run-program "/usr/local/bin/c2ffi"
                      (list "defines.h"
                            "--output" "defines.json"))
  (let ((spec (json:from-file "spec.json"))
        (defines (json:from-file "defines.json")))
    (delete-file "spec.json")
    (delete-file "defines.json")
    (delete-file "defines.h")
    (concatenate 'vector defines spec)))

(defun raw-array-p (type)
  (and (listp type)
       (eq (car type)
           :array)))

(defun define-argument (type)
  (if (raw-array-p type)
    (cons :pointer (cadr type))
    type))

(defun define-field (name type)
  (if (raw-array-p type)
    (cons name (cdr type))
    (list name type)))

; TODO: Handle different sizes of enum.
(defun cook-type (raw-type type-associations name-transformer)
  (let ((tag (gethash "tag" raw-type)))
    (cond ((string= tag ":void")
           :void)
          ((string= tag ":function-pointer")
           :pointer)
          ((string= tag ":pointer")
           (let ((pointed-type (gethash "type" raw-type)))
             (cond ((string= (gethash "tag" pointed-type) ":char")
                    :string)
                   ((string= (gethash "tag" pointed-type) ":void")
                    :pointer)
                   (t (list :pointer (define-argument
                                       (cook-type pointed-type type-associations name-transformer)))))))
          ((string= tag ":float")
           :float)
          ((or (string= tag ":double") (string= tag ":long-double"))
           :double)
          ((string= tag ":_Bool")
           :bool)
          ((string= tag ":unsigned-char")
           :unsigned-char)
          ((string= tag ":unsigned-short")
           :unsigned-short)
          ((string= tag ":unsigned-int")
           :unsigned-int)
          ((string= tag ":unsigned-long")
           :unsigned-long)
          ((string= tag ":unsigned-long-long")
           :unsigned-long-long)
          ((or (string= tag ":char") (string= tag ":signed-char"))
           :char)
          ((or (string= tag ":short") (string= tag ":signed-short"))
           :short)
          ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<))
           :int)
          ((or (string= tag ":long") (string= tag ":signed-long"))
           :long)
          ((or (string= tag ":long-long") (string= tag ":signed-long-long"))
           :long-long)
          ((string= tag ":array")
           (list :array (cook-type (gethash "type" raw-type) type-associations name-transformer)
                 :count
                 (gethash "size" raw-type)))
          ((string= tag ":struct")
           (list :struct (intern (funcall name-transformer (gethash "name" raw-type) :composite)
                                 +target-package+)))
          ((string= tag ":union")
           (list :union (intern (funcall name-transformer (gethash "name" raw-type) :composite)
                                +target-package+)))
          ((string= tag ":enum")
           :int)
          ((or (string= tag "struct") (string= tag "union"))
           (cons :struct
                 (cdr (cook-composite raw-type type-associations name-transformer))))
          ((string= tag "__builtin_va_list")
           :pointer)
          (t (let ((new-type (gethash tag type-associations)))
               (if new-type
                 (cook-type new-type type-associations name-transformer)
                 (error "Unknown type: ~a" tag)))))))

(defun cook-function (raw-function type-associations name-transformer)
  (let ((raw-params (gethash "parameters" raw-function))
        (cooked-params (queue:new)))
    (dotimes (j (length raw-params))
      (queue:add cooked-params
                 (list (if (string= (gethash "name" (aref raw-params j)) "")
                         (gensym)
                         (make-symbol (funcall name-transformer
                                               (gethash "name" (aref raw-params j))
                                               :argument)))
                       (define-argument
                         (cook-type (gethash "type" (aref raw-params j)) type-associations name-transformer)))))
    `(defcfun
       ,(let ((function-name (gethash "name" raw-function)))
          (list function-name (intern (funcall name-transformer function-name :function) +target-package+)))
       ,(define-argument
          (cook-type (gethash "return-type" raw-function) type-associations name-transformer))
       ,@(queue:to-list cooked-params))))

(defun cook-composite (raw-composite type-associations name-transformer)
  (let ((raw-fields (gethash "fields" raw-composite))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (define-field
                   (intern (string-upcase (gethash "name" (aref raw-fields j)))
                           'keyword)
                   (cook-type (gethash "type" (aref raw-fields j)) type-associations name-transformer))))
    `(,(find-symbol (string-upcase
                      (concatenate 'string
                                   "defc"
                                   (gethash "tag" raw-composite)))
                    'cffi)
       ,(intern (funcall name-transformer (gethash "name" raw-composite) :composite)
                +target-package+)
       ,@(queue:to-list cooked-fields))))

(defun cook-const (raw-const name-transformer)
  `(defconstant
     ,(intern (funcall name-transformer (gethash "name" raw-const) :const) +target-package+)
     ,(gethash "value" raw-const)))

(defun cook-enum (raw-enum enum-references name-transformer)
  (let ((name (if (> (gethash "id" raw-enum) 0)
                (gethash (gethash "id" raw-enum) enum-references)
                (gethash "name" raw-enum)))
        (raw-fields (gethash "fields" raw-enum))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 `(defconstant
                    ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const)
                             +target-package+)
                    ,(gethash "value" (aref raw-fields j)))))
    `(progn
       ,name
       ,@(queue:to-list cooked-fields))))

(defun generate-enum-references (raw-typedefs)
  (let ((enum-references (make-hash-table :test #'equal :size 256)))
    (dolist (i raw-typedefs)
      (let ((inner-type (gethash "type" i)))
        (when (string= (gethash "tag" inner-type) ":enum")
          (setf (gethash "name" inner-type) (gethash "name" i))
          (setf (gethash (gethash "id" inner-type) enum-references)
                (gethash "name" i)))))
    enum-references))

; Typedefs get "flattened" so that resolving is just a lookup.
(defun generate-type-associations (raw-typedefs)
  (let ((type-associations (make-hash-table :test #'equal :size 256)))
    (dolist (i raw-typedefs)
      (setf (gethash (gethash "name" i) type-associations) (gethash "type" i)))
    (labels ((flatten-typedef (k v)
                              (let ((new-v (gethash (gethash "tag" v) type-associations)))
                                (when new-v
                                  (setf (gethash k type-associations) new-v)
                                  (flatten-typedef k new-v)))))
      (maphash #'flatten-typedef type-associations))
    type-associations))

(defstruct spec
  consts
  functions
  typedefs
  composite
  enums)

; TODO: Sort the entries alphabetically, to increase consistency of generated files.
; This is done so we can separate definition types into stages when generating code.
; When processing typedefs we need to identify nested composite types and put them into the right buckets.
; What's left on the typedefs are references to said composite types.
; This allows for a comfier type resolution stage by letting us flatten typedefs.
; Composite types cause problems because they can't be redefined.
(defun classify-definitions (raw-spec)
  (let ((spec (make-spec)))
    (dotimes (i (length raw-spec))
      (classify-definition (aref raw-spec i) spec))
    spec))

(defun classify-definition (def spec)
  (let ((tag (gethash "tag" def)))
    (cond ((string= tag "function")
           (push def (spec-functions spec)))

          ((and (string= tag "const") (gethash "value" def))
           (push def (spec-consts spec)))

          ((or (string= tag "typedef")
               (string= tag ":array")
               (string= tag ":pointer"))
           (let* ((internal-type (gethash "type" def))
                  (internal-tag (gethash "tag" internal-type)))
             (cond ((or (string= internal-tag "struct")
                        (string= internal-tag "union"))
                    (setf (gethash "name" internal-type) (gethash "name" def))
                    (push internal-type (spec-composite spec))
                    (setf (gethash "type" def)
                          (json:obj ("tag" (gethash "tag" internal-type))
                                    ("name" (gethash "name" internal-type)))))
                   ((or (string= internal-tag ":array")
                        (string= internal-tag ":pointer"))
                    (classify-definition internal-type spec)))
             (when (string= tag "typedef")
               (push def (spec-typedefs spec)))))

          ((string= tag "enum")
           (push def (spec-enums spec)))

          ((or (string= tag "struct") (string= tag "union"))
           (push def (spec-composite spec)))))
  spec)

(defun find-dependency (field-type type-associations)
  (let* ((type-assoc (gethash (gethash "tag" field-type)
                              type-associations))
         (inner-type (or type-assoc field-type))
         (type-tag (gethash "tag" inner-type)))
    (cond ((or (string= type-tag ":struct")
               (string= type-tag "struct")
               (string= type-tag ":union")
               (string= type-tag "union"))
           (gethash "name" inner-type))
          ((or (string= type-tag ":pointer")
               (string= type-tag ":array"))
           (find-dependency (gethash "type" inner-type)
                            type-associations))
          (t nil))))

(defun gather-dependencies (raw-composite type-associations)
  (let ((result nil)
        (fields (gethash "fields" raw-composite)))
    (dotimes (i (length fields))
      (let* ((field-type (gethash "type" (aref fields i)))
             (dependency (find-dependency field-type type-associations)))
        (if dependency
          (push dependency result))))
    (cons raw-composite result)))

; Composites need to be defined in a partial ordering so dependencies are satisfied.
(defun sort-composites (raw-composites type-associations)
  (labels ((partial-sort (leaves roots)
                         (if roots
                           (let ((new-leaves (mapcar
                                               (lambda (x) (car x))
                                               (remove-if
                                                 (lambda (x) (> (length x) 1))
                                                 roots)))
                                 (new-roots (remove-if
                                              (lambda (x) (= (length x) 1))
                                              roots)))
                             (dolist (i new-leaves)
                               (let ((leaf-name (gethash "name" i)))
                                 (dolist (j new-roots)
                                   (delete leaf-name j :test #'equal))))
                             (partial-sort (concatenate 'list
                                                        leaves
                                                        new-leaves)
                                           new-roots))
                           leaves)))
    (let ((result (partial-sort nil
                                (mapcar (lambda (x)
                                          (gather-dependencies x type-associations))
                                        raw-composites))))
      result)))

(defun codegen (spec name-transformer)
  (let ((enum-references (generate-enum-references (spec-typedefs spec)))
        (type-associations (generate-type-associations (spec-typedefs spec))))
    (let ((consts (mapcar (lambda (x) (cook-const x name-transformer))
                          (spec-consts spec)))
          (enums (mapcar (lambda (x) (cook-enum x enum-references name-transformer))
                         (spec-enums spec)))
          (composite (mapcar (lambda (x) (cook-composite x type-associations name-transformer))
                             (sort-composites (spec-composite spec)
                                              type-associations)))
          (functions (mapcar (lambda (x) (cook-function x type-associations name-transformer))
                             (spec-functions spec))))
      (remove-duplicates (concatenate 'list consts enums composite functions) :test #'equal))))

; TODO: Generate a lisp file for every header file.
; TODO: Generate a file for the shared objects.
; TODO: Create an asd file referencing the generated files.
(defun to-file (code filename pkg-name shared-object)
  (with-open-file (f "package.lisp"
                     :direction :output
                     :if-exists nil)
    (format f "(DEFPACKAGE #:~a~&  (:EXPORT" pkg-name)
    (let ((*package* (find-package +target-package+)))
      (do-symbols (s *package*) (format f "~&    #:~s" s)))
    (format f "))~&")
    (when shared-object
      (format f "~s~&"
              `(cffi:define-foreign-library ,pkg-name
                                            (:unix ,shared-object)))
      (format f "~s~&"
              `(cffi:use-foreign-library ,pkg-name))))
  (with-open-file (f filename
                     :direction :output
                     :if-exists nil)
    (let ((*print-length* nil)
          (*print-level* nil)
          (*package* (find-package +target-package+)))
      (format f "(COMMON-LISP:IN-PACKAGE #:~a)~&" pkg-name)
      (format f "~{~s~&~}" code))))

(defun filter-directories (search-directories raw-spec)
  (remove-if (lambda (x)
               (and (notany (lambda (dir)
                              (let ((location (gethash "location" x)))
                                (string= dir location :end2 (min (length location) (length dir)))))
                            search-directories)
                    (string/= (gethash "tag" x) "typedef")
                    (string/= (gethash "tag" x) "const")))
             raw-spec))

(defun default-name-transformer (name type)
  (cond ((eq type :const)
         (concatenate 'string "+" (string-upcase (str:underscore->hyphen name)) "+"))
        (t (string-upcase
             (str:pascal->kebab
               (str:upcase->pascal
                 (str:underscore->hyphen name)))))))

; TODO: Handle multiple header files and shared objects.
(defun generate-bindings (package-name &key header-file shared-object additional-directories name-transformer)
  (unless (probe-file header-file)
    (error (format t "The header file ~a doesn't exist!" header-file)))
  (when (not (find-package +target-package+))
    (make-package +target-package+))
  (setf header-file (parse-namestring header-file))
  (push (directory-namestring header-file) additional-directories)
  (let* ((raw-spec (get-raw-spec (namestring header-file) additional-directories))
         (spec (classify-definitions (filter-directories additional-directories raw-spec)))
         (code (codegen spec (or name-transformer #'default-name-transformer))))
    (to-file code (concatenate 'string (pathname-name header-file) ".lisp") package-name shared-object))
  (delete-package (find-package +target-package+)))