Tweak code generation

1 files changed, 41 insertions, 43 deletions

diff --git a/cmamut.lisp b/cmamut.lisp
index a5133a0..7e6c23c 100644
--- a/cmamut.lisp
+++ b/cmamut.lisp
@@ -4,24 +4,19 @@
 ; Generate code that creates a package and puts all definitions there.
 ; To avoid collisions the created package shouldn't import any symbols.
 ; Only define functions from the target library, but get all other definitions.
-; To reduce amount of names being generated, resolve all types to their base counterparts
-; Separate generation, preprocessing and type resolution phases
-; Preprocessing phase should handle enums, structs and unions
-; Basic types are handled by type resolution phase
-; Can put an error to default case in cook type to enforce type resolution
 
 ; TODO: Get constants from macro file generated by c2ffi -M
 
 ; TODO: Use c2ffi to extract the spec.json using the header file as parameter
-(defun get-raw-spec ()
-  (json:from-file "~/common-lisp/cmamut/spec.json"))
+(defun get-raw-spec (filename)
+  (json:from-file filename))
 
 (defun cook-type (raw-type type-associations)
   (let ((tag (gethash "tag" raw-type)))
     (cond ((string= tag ":void")
            'sb-alien:void)
           ((string= tag ":function-pointer")
-           'sb-alien:function)
+           (list 'sb-alien:* t))
           ((string= tag ":pointer")
            (let ((pointed-type (gethash "type" raw-type)))
              (cond ((string= (gethash "tag" pointed-type) ":char")
@@ -31,7 +26,7 @@
                    (t (list 'sb-alien:* (cook-type pointed-type type-associations))))))
           ((string= tag ":float")
            'sb-alien:float)
-          ((string= tag ":double")
+          ((or (string= tag ":double") (string= tag ":long-double"))
            'sb-alien:double)
           ((string= tag ":unsigned-char")
            'sb-alien:unsigned-char)
@@ -41,14 +36,18 @@
            '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"))
+          ((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)
@@ -57,10 +56,14 @@
            (list 'sb-alien:struct (intern (gethash "name" raw-type))))
           ((string= tag ":union")
            (list 'sb-alien:union (intern (gethash "name" raw-type))))
+          ((string= tag ":enum")
+           (list 'sb-alien:enum (gethash "name" raw-type)))
           ((string= tag "struct")
-           (cook-struct raw-type))
+           (cook-struct raw-type type-associations))
           ((string= tag "union")
-           (cook-union raw-type))
+           (cook-union 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)
@@ -71,7 +74,7 @@
         (cooked-params (queue:new)))
     (dotimes (j (length raw-params))
       (queue:add cooked-params
-                 (list (intern (string-upcase (gethash "name" (aref raw-params j))))
+                 (list (intern (gethash "name" (aref raw-params j)))
                        (cook-type (gethash "type" (aref raw-params j)) type-associations))))
     `(sb-alien:define-alien-routine
        ,(let ((function-name (gethash "name" raw-function)))
@@ -86,7 +89,7 @@
         (cooked-fields (queue:new)))
     (dotimes (j (length raw-fields))
       (queue:add cooked-fields
-                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
+                 (list (intern (gethash "name" (aref raw-fields j)))
                        (cook-type (gethash "type" (aref raw-fields j)) type-associations))))
     `(sb-alien:struct
        ,(when (> (length (gethash "name" raw-struct)) 0)
@@ -98,7 +101,7 @@
         (cooked-fields (queue:new)))
     (dotimes (j (length raw-fields))
       (queue:add cooked-fields
-                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
+                 (list (intern (gethash "name" (aref raw-fields j)))
                        (cook-type (gethash "type" (aref raw-fields j)) type-associations))))
     `(sb-alien:union
        ,(when (> (length (gethash "name" raw-union)) 0)
@@ -111,12 +114,12 @@
         (cooked-fields (queue:new)))
     (dotimes (j (length raw-fields))
       (queue:add cooked-fields
-                 (list (intern (string-upcase (gethash "name" (aref raw-fields j))))
+                 (list (intern (gethash "name" (aref raw-fields j)))
                        (gethash "value" (aref raw-fields j)))))
     `(sb-alien:define-alien-type
-       ,name
+       nil
        (sb-alien:enum
-         nil
+         ,name
          ,@(queue:to-list cooked-fields)))))
 
 (defun generate-enum-references (raw-typedefs)
@@ -128,7 +131,6 @@
                 (gethash "name" i)))))
     enum-references))
 
-; Generates a table for type resolution.
 ; 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)))
@@ -195,30 +197,20 @@
            (push def (spec-unions spec)))))
   spec)
 
-;(defun codegen (spec)
-;  (let ((enum-references (generate-enum-references (spec-typedefs spec)))
-;        (type-associations (generate-type-associations (spec-typedefs spec)))
-;        (code nil))
-;  ((mapcar #'cook-enum (spec-enums spec)))
-;  (setf (spec-structs spec)
-;        (mapcar (lambda (x)
-;                  `(sb-alien:define-alien-type nil ,(cook-struct x)))
-;                (spec-structs spec)))
-;  (setf (spec-unions spec)
-;        (mapcar (lambda (x)
-;                  `(sb-alien:define-alien-type nil ,(cook-union x)))
-;                (spec-unions spec)))
-;  (setf (spec-functions spec) (mapcar #'cook-function (spec-functions spec)))
-;  spec)
-
-(defun to-json-file (code filename)
-  (with-open-file (f filename
-                     :direction :output
-                     :if-exists :supersede
-                     :if-does-not-exist :create)
-    (let ((*print-length* nil)
-          (*print-level* nil))
-      (format f "~{~a~&~}" (mapcar #'json:to-string code)))))
+(defun codegen (spec)
+  (let ((enum-references (generate-enum-references (spec-typedefs spec)))
+        (type-associations (generate-type-associations (spec-typedefs spec))))
+    (let ((enums (mapcar (lambda (x) (cook-enum x enum-references))
+                         (spec-enums spec)))
+          (structs (mapcar (lambda (x)
+                             `(sb-alien:define-alien-type nil ,(cook-struct x type-associations)))
+                           (spec-structs spec)))
+          (unions (mapcar (lambda (x)
+                            `(sb-alien:define-alien-type nil ,(cook-union x type-associations)))
+                          (spec-unions spec)))
+          (functions (mapcar (lambda (x) (cook-function x type-associations))
+                             (spec-functions spec))))
+      (remove-duplicates (concatenate 'list enums structs unions functions) :test #'equal))))
 
 (defun to-file (code filename)
   (with-open-file (f filename
@@ -228,3 +220,9 @@
     (let ((*print-length* nil)
           (*print-level* nil))
       (format f "~{~s~&~}" code))))
+
+(defun run (input output)
+  (let* ((raw-spec (get-raw-spec input))
+         (spec (classify-definitions raw-spec))
+         (code (codegen spec)))
+    (to-file code output)))