Start to revert dependency on cffi to use native struct handlingHEADmain

4 files changed, 133 insertions, 75 deletions

diff --git a/cmamut.asd b/cmamut.asd
index 80ccda9..c07b3ff 100644
--- a/cmamut.asd
+++ b/cmamut.asd
@@ -1,6 +1,7 @@
-(asdf:defsystem #:cmamut
+(defsystem "cmamut"
   :serial t
-  :depends-on (#:cffi #:json)
+  :depends-on ("monparser" "json" "utils")
   :components
   ((:file "package")
+   (:file "header")
    (:file "cmamut")))
diff --git a/cmamut.lisp b/cmamut.lisp
index 4191085..094e2da 100644
--- a/cmamut.lisp
+++ b/cmamut.lisp
@@ -28,79 +28,61 @@
     (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)
+           'sb-alien:void)
           ((string= tag ":function-pointer")
-           :pointer)
+           (list 'sb-alien:* t))
           ((string= tag ":pointer")
            (let ((pointed-type (gethash "type" raw-type)))
              (cond ((string= (gethash "tag" pointed-type) ":char")
-                    :string)
+                    'sb-alien:c-string)
                    ((string= (gethash "tag" pointed-type) ":void")
-                    :pointer)
-                   (t (list :pointer (define-argument
-                                       (cook-type pointed-type type-associations name-transformer)))))))
+                    (list 'sb-alien:* t))
+                   (t (list 'sb-alien:* (cook-type pointed-type type-associations name-transformer))))))
           ((string= tag ":float")
-           :float)
+           'sb-alien:float)
           ((or (string= tag ":double") (string= tag ":long-double"))
-           :double)
+           'sb-alien:double)
           ((string= tag ":_Bool")
-           :bool)
+           'sb-alien:unsigned-char)
           ((string= tag ":unsigned-char")
-           :unsigned-char)
+           'sb-alien:unsigned-char)
           ((string= tag ":unsigned-short")
-           :unsigned-short)
+           'sb-alien:unsigned-short)
           ((string= tag ":unsigned-int")
-           :unsigned-int)
+           'sb-alien:unsigned-int)
           ((string= tag ":unsigned-long")
-           :unsigned-long)
+           'sb-alien:unsigned-long)
           ((string= tag ":unsigned-long-long")
-           :unsigned-long-long)
+           'sb-alien:unsigned-long-long)
           ((or (string= tag ":char") (string= tag ":signed-char"))
-           :char)
+           'sb-alien:char)
           ((or (string= tag ":short") (string= tag ":signed-short"))
-           :short)
+           'sb-alien:short)
           ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<))
-           :int)
+           'sb-alien:int)
           ((or (string= tag ":long") (string= tag ":signed-long"))
-           :long)
+           'sb-alien:long)
           ((or (string= tag ":long-long") (string= tag ":signed-long-long"))
-           :long-long)
+           'sb-alien:long-long)
           ((string= tag ":array")
-           (list :array (cook-type (gethash "type" raw-type) type-associations name-transformer)
-                 :count
+           (list 'sb-alien:array (cook-type (gethash "type" raw-type) type-associations name-transformer)
                  (gethash "size" raw-type)))
           ((string= tag ":struct")
-           (list :struct (intern (funcall name-transformer (gethash "name" raw-type) :composite)
-                                 +target-package+)))
+           (list 'sb-alien: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+)))
+           (list 'sb-alien:union (intern (funcall name-transformer (gethash "name" raw-type) :composite)
+                                         +target-package+)))
           ((string= tag ":enum")
-           :int)
+           'sb-alien:int)
           ((or (string= tag "struct") (string= tag "union"))
-           (cons :struct
-                 (cdr (cook-composite raw-type type-associations name-transformer))))
+           (cook-composite raw-type type-associations name-transformer))
           ((string= tag "__builtin_va_list")
-           :pointer)
+           (list 'sb-alien:* t))
           (t (let ((new-type (gethash tag type-associations)))
                (if new-type
                  (cook-type new-type type-associations name-transformer)
@@ -110,15 +92,15 @@
   (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
+      (queue:push (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)))
+                  cooked-params))
+    `(sb-alien:define-alien-routine
        ,(let ((function-name (gethash "name" raw-function)))
           (list function-name (intern (funcall name-transformer function-name :function) +target-package+)))
        ,(define-argument
@@ -129,16 +111,13 @@
   (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)
+      (queue:push (define-field
+                    (intern (string-upcase (gethash "name" (aref raw-fields j)))
+                            'keyword)
+                    (cook-type (gethash "type" (aref raw-fields j)) type-associations name-transformer))
+                  cooked-fields))
+    `(,(find-symbol (string-upcase (gethash "tag" raw-composite))
+                    'sb-alien)
        ,(intern (funcall name-transformer (gethash "name" raw-composite) :composite)
                 +target-package+)
        ,@(queue:to-list cooked-fields))))
@@ -155,11 +134,11 @@
         (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)))))
+      (queue:push `(defconstant
+                     ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const)
+                              +target-package+)
+                     ,(gethash "value" (aref raw-fields j)))
+                  cooked-fields))
     `(progn
        ,name
        ,@(queue:to-list cooked-fields))))
@@ -319,10 +298,7 @@
     (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))))
+              `(load-shared-object ,shared-object))))
   (with-open-file (f filename
                      :direction :output
                      :if-exists nil)
diff --git a/header.lisp b/header.lisp
new file mode 100644
index 0000000..36b34d9
--- /dev/null
+++ b/header.lisp
@@ -0,0 +1,77 @@
+(in-package #:header)
+
+; TODO: structs/unions, enums, typedefs, handle preprocessor stuff.
+
+(defparser whitespace ()
+  (optional (many (unit #'whitespace?))))
+
+(defparser preprocessor ()
+  (comp ((_ (unit #\#))
+         (keyword (many (unit #'alphanumericp)))
+         (_ whitespace)
+         (body (optional (many (one-of (unit (char/= it #\Newline))
+                                       (comp ((_ (unit #\Backslash))
+                                              (c (unit)))
+                                         c)))))
+         (_ (unit #\Newline)))
+    (cons (coerce keyword 'string) (coerce body 'string))))
+
+(defparser block-comment ()
+  (comp ((_ (literal "/*"))
+         (_ (optional
+              (many
+                (comp ((end? (optional (literal "*/")))
+                       (other (if end?
+                                (fail "Unreachable")
+                                (unit))))
+                  other))))
+         (_ (literal "*/")))
+    nil))
+
+(defparser line-comment ()
+  (comp ((_ (literal "//"))
+         (_ (optional (many (unit (char/= it #\Newline)))))
+         (_ (unit #\Newline)))
+    nil))
+
+(defun valid-char? (c first?)
+  (or (if first?
+        (alpha-char-p c)
+        (alphanumericp c))
+      (some (lambda (x) (char= c x))
+            '(#\_ #\@ #\# #\$))))
+
+(defparser identifier ()
+  (comp ((first (unit (valid-char? it t)))
+         (rest (optional (many (unit (valid-char? it nil))))))
+    (coerce (cons first rest) 'string)))
+
+(defparser function-declaration ()
+  (comp ((type identifier)
+         (_ whitespace)
+         (name identifier)
+         (_ whitespace)
+         (args (within
+                 (unit #\()
+                 (optional (interlinked
+                             (comp ((_ whitespace)
+                                    (type (identifier))
+                                    (_ whitespace)
+                                    (stars (optional (many (unit #\*))))
+                                    (_ whitespace)
+                                    (name (optional identifier))
+                                    (_ whitespace))
+                               (list type (length stars) name))
+                             (unit #\,)))
+                 (unit #\))))
+         (_ whitespace)
+         (_ (unit #\;)))
+    (list type name args)))
+
+(defparser parser ()
+  (optional (many (within whitespace
+                          (one-of block-comment
+                                  line-comment
+                                  preprocessor
+                                  function-declaration))
+                  :all t)))
diff --git a/package.lisp b/package.lisp
index 5660b54..6258713 100644
--- a/package.lisp
+++ b/package.lisp
@@ -1,4 +1,8 @@
+(defpackage #:header
+  (:use #:cl #:monparser)
+  (:export #:parser))
+
 (defpackage #:cmamut
-  (:use #:cffi #:cl)
+  (:use #:cl)
   (:export #:generate-bindings
            #:default-name-transformer))