Integrate struct pass by value using cffiHEADmain

3 files changed, 166 insertions, 116 deletions

diff --git a/cmamut.asd b/cmamut.asd
index a7fa800..80ccda9 100644
--- a/cmamut.asd
+++ b/cmamut.asd
@@ -1,6 +1,6 @@
 (asdf:defsystem #:cmamut
   :serial t
-  :depends-on (#:json)
+  :depends-on (#:cffi #:json)
   :components
   ((:file "package")
    (:file "cmamut")))
diff --git a/cmamut.lisp b/cmamut.lisp
index e608c25..4191085 100644
--- a/cmamut.lisp
+++ b/cmamut.lisp
@@ -2,11 +2,14 @@
 
 (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/bin/c2ffi" (list filename
-                                             "--macro-file" "defines.h"
-                                             "--with-macro-defs"
-                                             "--output" "spec.json"))
+  (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)
@@ -15,8 +18,9 @@
               (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"))
+  (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")
@@ -24,61 +28,82 @@
     (delete-file "defines.h")
     (concatenate 'vector defines spec)))
 
-; TODO: Handle different sizes of enum
-(defun cook-type (raw-type type-associations)
+(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")
-           'sb-alien:void)
+           :void)
           ((string= tag ":function-pointer")
-           (list 'sb-alien:* t))
+           :pointer)
           ((string= tag ":pointer")
            (let ((pointed-type (gethash "type" raw-type)))
              (cond ((string= (gethash "tag" pointed-type) ":char")
-                    'sb-alien:c-string)
+                    :string)
                    ((string= (gethash "tag" pointed-type) ":void")
-                    (list 'sb-alien:* t))
-                   (t (list 'sb-alien:* (cook-type pointed-type type-associations))))))
+                    :pointer)
+                   (t (list :pointer (define-argument
+                                       (cook-type pointed-type type-associations name-transformer)))))))
           ((string= tag ":float")
-           'sb-alien:float)
+           :float)
           ((or (string= tag ":double") (string= tag ":long-double"))
-           'sb-alien:double)
-          ((or (string= tag ":unsigned-char") (string= tag ":_Bool"))
-           'sb-alien:unsigned-char)
+           :double)
+          ((string= tag ":_Bool")
+           :bool)
+          ((string= tag ":unsigned-char")
+           :unsigned-char)
           ((string= tag ":unsigned-short")
-           'sb-alien:unsigned-short)
+           :unsigned-short)
           ((string= tag ":unsigned-int")
-           'sb-alien:unsigned-int)
+           :unsigned-int)
           ((string= tag ":unsigned-long")
-           'sb-alien:unsigned-long)
+           :unsigned-long)
           ((string= tag ":unsigned-long-long")
-           'sb-alien:unsigned-long-long)
+           :unsigned-long-long)
           ((or (string= tag ":char") (string= tag ":signed-char"))
-           'sb-alien:char)
+           :char)
           ((or (string= tag ":short") (string= tag ":signed-short"))
-           'sb-alien:short)
+           :short)
           ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<))
-           'sb-alien:int)
+           :int)
           ((or (string= tag ":long") (string= tag ":signed-long"))
-           'sb-alien:long)
+           :long)
           ((or (string= tag ":long-long") (string= tag ":signed-long-long"))
-           'sb-alien:long-long)
+           :long-long)
           ((string= tag ":array")
-           (list 'sb-alien:array
-                 (cook-type (gethash "type" raw-type) type-associations)
+           (list :array (cook-type (gethash "type" raw-type) type-associations name-transformer)
+                 :count
                  (gethash "size" raw-type)))
           ((string= tag ":struct")
-           (list 'sb-alien:struct (intern (gethash "name" raw-type) +target-package+)))
+           (list :struct (intern (funcall name-transformer (gethash "name" raw-type) :composite)
+                                 +target-package+)))
           ((string= tag ":union")
-           (list 'sb-alien:union (intern (gethash "name" raw-type) +target-package+)))
+           (list :union (intern (funcall name-transformer (gethash "name" raw-type) :composite)
+                                +target-package+)))
           ((string= tag ":enum")
-           'sb-alien:int)
+           :int)
           ((or (string= tag "struct") (string= tag "union"))
-           (cook-composite raw-type type-associations))
+           (cons :struct
+                 (cdr (cook-composite raw-type type-associations name-transformer))))
           ((string= tag "__builtin_va_list")
-           (list 'sb-alien:* t))
+           :pointer)
           (t (let ((new-type (gethash tag type-associations)))
                (if new-type
-                 (cook-type new-type type-associations)
+                 (cook-type new-type type-associations name-transformer)
                  (error "Unknown type: ~a" tag)))))))
 
 (defun cook-function (raw-function type-associations name-transformer)
@@ -88,24 +113,34 @@
       (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
+                         (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+)))
-       ,(cook-type (gethash "return-type" raw-function) type-associations)
+       ,(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)
+(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
-                 (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+))
+                 (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)
@@ -122,7 +157,8 @@
     (dotimes (j (length raw-fields))
       (queue:add cooked-fields
                  `(defconstant
-                    ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const) +target-package+)
+                    ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const)
+                             +target-package+)
                     ,(gethash "value" (aref raw-fields j)))))
     `(progn
        ,name
@@ -143,12 +179,11 @@
   (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)))))
+    (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))
 
@@ -159,6 +194,7 @@
   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.
@@ -185,8 +221,7 @@
                   (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)))
+                    (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))
@@ -204,43 +239,58 @@
            (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 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 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 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)))
@@ -249,39 +299,37 @@
                           (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)))))
+          (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: Export only the transformed symbols
+; 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 :supersede
-                     :if-does-not-exist :create)
+                     :if-exists nil)
     (let ((*print-length* nil)
           (*print-level* nil)
-          (*print-pretty* t)
           (*package* (find-package +target-package+)))
-      (when pkg-name
-        (format f "(COMMON-LISP:DEFPACKAGE #:~a~&  (:EXPORT" (string-upcase pkg-name))
-        (do-symbols (s *package*) (format f "~&    #:~s" s))
-        (format f "))~&(COMMON-LISP:IN-PACKAGE #:~a)~&" (string-upcase pkg-name)))
-      (when shared-object
-        (let ((loaded? (intern "LOADED?" +target-package+)))
-          (format f
-                  "~s~&"
-                  `(let ((,loaded? nil))
-                     (sb-alien:load-shared-object ,shared-object)
-                     (setf ,loaded? t)))))
+      (format f "(COMMON-LISP:IN-PACKAGE #:~a)~&" pkg-name)
       (format f "~{~s~&~}" code))))
 
 (defun filter-directories (search-directories raw-spec)
@@ -302,7 +350,8 @@
                (str:upcase->pascal
                  (str:underscore->hyphen name)))))))
 
-(defun run (header-file &key package-name shared-object additional-directories name-transformer)
+; 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+))
diff --git a/package.lisp b/package.lisp
index 477d049..5660b54 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,3 +1,4 @@
 (defpackage #:cmamut
-  (:use #:cl)
-  (:export #:run))
+  (:use #:cffi #:cl)
+  (:export #:generate-bindings
+           #:default-name-transformer))