path: root/cmamut.lisp

(in-package #:cmamut)

(defparameter +target-package+ (gensym))

(defun get-raw-spec (filename search-directories)
  (sb-ext:run-program "/usr/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/bin/c2ffi" '("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)))

; TODO: Handle different sizes of enum
(defun cook-type (raw-type type-associations)
  (let ((tag (gethash "tag" raw-type)))
    (cond ((string= tag ":void")
           'sb-alien:void)
          ((string= tag ":function-pointer")
           (list 'sb-alien:* t))
          ((string= tag ":pointer")
           (let ((pointed-type (gethash "type" raw-type)))
             (cond ((string= (gethash "tag" pointed-type) ":char")
                    'sb-alien:c-string)
                   ((string= (gethash "tag" pointed-type) ":void")
                    (list 'sb-alien:* t))
                   (t (list 'sb-alien:* (cook-type pointed-type type-associations))))))
          ((string= tag ":float")
           'sb-alien:float)
          ((or (string= tag ":double") (string= tag ":long-double"))
           'sb-alien:double)
          ((or (string= tag ":unsigned-char") (string= tag ":_Bool"))
           'sb-alien:unsigned-char)
          ((string= tag ":unsigned-short")
           'sb-alien:unsigned-short)
          ((string= tag ":unsigned-int")
           'sb-alien:unsigned-int)
          ((string= tag ":unsigned-long")
           'sb-alien:unsigned-long)
          ((string= tag ":unsigned-long-long")
           'sb-alien:unsigned-long-long)
          ((or (string= tag ":char") (string= tag ":signed-char"))
           'sb-alien:char)
          ((or (string= tag ":short") (string= tag ":signed-short"))
           'sb-alien:short)
          ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<))
           'sb-alien:int)
          ((or (string= tag ":long") (string= tag ":signed-long"))
           'sb-alien:long)
          ((or (string= tag ":long-long") (string= tag ":signed-long-long"))
           'sb-alien:long-long)
          ((string= tag ":array")
           (list 'sb-alien:array
                 (cook-type (gethash "type" raw-type) type-associations)
                 (gethash "size" raw-type)))
          ((string= tag ":struct")
           (list 'sb-alien:struct (intern (gethash "name" raw-type) +target-package+)))
          ((string= tag ":union")
           (list 'sb-alien:union (intern (gethash "name" raw-type) +target-package+)))
          ((string= tag ":enum")
           'sb-alien:int)
          ((or (string= tag "struct") (string= tag "union"))
           (cook-composite raw-type type-associations))
          ((string= tag "__builtin_va_list")
           (list 'sb-alien:* t))
          (t (let ((new-type (gethash tag type-associations)))
               (if new-type
                 (cook-type new-type type-associations)
                 (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)
                         (intern (gethash "name" (aref raw-params j)) +target-package+))
                       (cook-type (gethash "type" (aref raw-params j)) type-associations))))
    `(sb-alien:define-alien-routine
       ,(let ((function-name (gethash "name" raw-function)))
          (list function-name (intern (funcall name-transformer function-name :function) +target-package+)))
       ,(cook-type (gethash "return-type" raw-function) type-associations)
       ,@(queue:to-list cooked-params))))

(defun cook-composite (raw-composite type-associations)
  (let ((raw-fields (gethash "fields" raw-composite))
        (cooked-fields (queue:new)))
    (dotimes (j (length raw-fields))
      (queue:add cooked-fields
                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))) 'keyword)
                       (cook-type (gethash "type" (aref raw-fields j)) type-associations))))
    `(,(intern (string-upcase (gethash "tag" raw-composite)) 'sb-alien)
       ,(when (> (length (gethash "name" raw-composite)) 0)
          (intern (gethash "name" raw-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)

; 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"))
                    (when (string= (gethash "name" internal-type) "")
                      (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 gather-composite-dependencies (composite)
  (let ((names (make-hash-table)))
    (labels ((get-deps
               (def)
               (dolist (param (cddr def))
                 (let ((param-type (cadr param)))
                   (when (listp param-type)
                     (cond ((or (eql (car param-type) 'sb-alien:struct)
                                (eql (car param-type) 'sb-alien:union))
                            (setf (gethash (cadr param-type) names) t)
                            (get-deps param-type))
                           ((and (eql (car param-type) 'sb-alien:array)
                                 (listp (cadr param-type)))
                            (setf (gethash (caadr param-type) names) t)
                            (get-deps (cadr param-type)))))))))
      (get-deps composite))
    names))

(defun sort-composites-by-deps (composites)
  (let ((comps-and-deps (mapcar (lambda (x)
                                  (cons x (gather-composite-dependencies x)))
                                composites))
        (result nil))
    (labels ((filter-deps
               (cnd)
               (let ((new-cnd (remove-if (lambda (x) (= (hash-table-count (cdr x)) 0)) cnd)))
                 (if (= (length new-cnd) (length cnd))
                   result
                   (progn
                     (dolist (i cnd)
                       (when (= (hash-table-count (cdr i)) 0)
                         (push (car i) result)
                         (dolist (j new-cnd)
                           (remhash (second (car i)) (cdr j)))))
                     (filter-deps new-cnd))))))
      (filter-deps comps-and-deps))
    (reverse 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)
                               `(sb-alien:define-alien-type
                                  ,(intern (funcall name-transformer (symbol-name (cadr x)) :composite)
                                           +target-package+)
                                  ,x))
                             (sort-composites-by-deps
                               (mapcar (lambda (x) (cook-composite x type-associations))
                                       (spec-composite spec)))))
          (functions (mapcar (lambda (x) (cook-function x type-associations name-transformer))
                             (spec-functions spec))))
      (remove-duplicates (concatenate 'list consts enums composite functions) :test #'equal))))

(defun to-file (code filename pkg-name shared-object)
  (with-open-file (f filename
                     :direction :output
                     :if-exists :supersede
                     :if-does-not-exist :create)
    (let ((*print-length* nil)
          (*print-level* nil)
          (*print-pretty* t)
          (*package* (find-package +target-package+)))
      (when shared-object
        (format f
                "(COMMON-LISP:LET ((LOADED? COMMON-LISP:NIL))~&  (SB-ALIEN:LOAD-SHARED-OBJECT ~s)~&  (COMMON-LISP:SETF LOADED? COMMON-LISP:T))~&"
                shared-object))
      (when pkg-name
        (format f "(COMMON-LISP:DEFPACKAGE #:~a)~&" (string-upcase pkg-name))
        (format f "(COMMON-LISP:IN-PACKAGE #:~a)~&" (string-upcase pkg-name)))
      (format f "~{~s~&~}" code)
      (do-symbols (s *package*) (format f "(COMMON-LISP:EXPORT '~s)~&" s)))))

(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 run (path-to-header-file &key package-name shared-object additional-directories name-transformer)
  (unless (probe-file path-to-header-file)
    (error (format t "The header file ~a doesn't exist!" path-to-header-file)))
  (when (not (find-package +target-package+))
    (make-package +target-package+))
  (setf path-to-header-file (parse-namestring path-to-header-file))
  (push (directory-namestring path-to-header-file) additional-directories)
  (let* ((raw-spec (get-raw-spec (namestring path-to-header-file) additional-directories))
         (spec (classify-definitions (filter-directories additional-directories raw-spec)))
         (code (codegen spec (or name-transformer (lambda (name kind) name)))))
    (to-file code (concatenate 'string (pathname-name path-to-header-file) ".lisp") package-name shared-object))
  (delete-package (find-package +target-package+)))