Implement most of the generation

2 files changed, 172 insertions, 1 deletions

diff --git a/cmamut.asd b/cmamut.asd
index e37056b..a7fa800 100644
--- a/cmamut.asd
+++ b/cmamut.asd
@@ -1,6 +1,6 @@
 (asdf:defsystem #:cmamut
   :serial t
-  :depends-on ()
+  :depends-on (#:json)
   :components
   ((:file "package")
    (:file "cmamut")))
diff --git a/cmamut.lisp b/cmamut.lisp
index 7b64756..97db0f5 100644
--- a/cmamut.lisp
+++ b/cmamut.lisp
@@ -1 +1,172 @@
 (in-package #:cmamut)
+
+; Ideas:
+; Generate code that creates a package and puts all definitions there.
+; If symbol names are unaltered we can skip connecting everything together.
+; To avoid collisions the created package shouldn't import any symbols.
+; Maybe use straight defuns and ffi functions to get as close as possible to the C names without much work.
+; Only define functions from the target library, but get all other definitions.
+
+; TODO: Get constants from macro file generated by c2ffi -M
+; TODO: Generate enum definitions
+
+(defvar reference-table (make-hash-table :test #'equal :size 256))
+
+(defun get-spec ()
+  (json:from-file "~/common-lisp/cmamut/spec.json"))
+
+(defun cook-type (raw-type)
+  (let ((tag (gethash "tag" raw-type)))
+    (cond ((string= tag ":void")
+           'sb-alien:void)
+          ((string= tag ":function-pointer")
+           'sb-alien:function)
+          ((string= tag ":pointer")
+           (let ((pointed-type (gethash "type" raw-type)))
+             (if (string= (gethash "tag" pointed-type) ":char")
+               'sb-alien:c-string
+               (list 'sb-alien:* (cook-type pointed-type)))))
+          ((string= tag ":float")
+           'sb-alien:float)
+          ((string= tag ":double")
+           'sb-alien:double)
+          ((string= tag ":unsigned-char")
+           '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 ":char")
+           'sb-alien:char)
+          ((string= tag ":short")
+           'sb-alien:short)
+          ((string= tag ":int")
+           'sb-alien:int)
+          ((string= tag ":long")
+           'sb-alien:long)
+          ((string= tag ":struct")
+           (list 'sb-alien:struct (gethash "name" raw-type)))
+          ((string= tag ":union")
+           (list 'sb-alien:union (gethash "name" raw-type)))
+          ((string= tag "struct")
+           (cook-struct raw-type))
+          ((string= tag "union")
+           (cook-union raw-type))
+          (t tag))))
+
+(defun cook-function (raw-function &optional name-transformer)
+  (let ((raw-params (gethash "parameters" raw-function))
+        (cooked-params (queue:new)))
+    (dotimes (j (length raw-params))
+      (queue:add cooked-params
+                 (list (intern (gethash "name" (aref raw-params j)))
+                       (cook-type (gethash "type" (aref raw-params j))))))
+    `(sb-alien:define-alien-routine
+       ,(let ((function-name (gethash "name" raw-function)))
+          (if name-transformer
+            (list function-name (funcall name-transformer function-name))
+            function-name))
+       ,(cook-type (gethash "return-type" raw-function))
+       ,@(queue:to-list cooked-params))))
+
+(defun cook-typedef (raw-typedef)
+  (let* ((base-type (gethash "type" raw-typedef))
+         (new-name (gethash "name" raw-typedef))
+         (enum? (string= (gethash "tag" base-type) ":enum")))
+    (when enum?
+      (setf (gethash (gethash "id" base-type) reference-table)
+            new-name))
+    `(sb-alien:define-alien-type
+       ,new-name
+       ,(if enum?
+          `(enum ,new-name)
+          (cook-type base-type)))))
+
+(defun cook-struct (raw-struct)
+  (let ((raw-fields (gethash "fields" raw-struct))
+        (cooked-fields (queue:new)))
+    (dotimes (j (length raw-fields))
+      (queue:add cooked-fields
+                 (list (intern (gethash "name" (aref raw-fields j)))
+                       (cook-type (gethash "type" (aref raw-fields j))))))
+    `(sb-alien:struct
+       ,(gethash "name" raw-struct)
+       ,@(queue:to-list cooked-fields))))
+
+(defun cook-union (raw-union)
+  (let ((raw-fields (gethash "fields" raw-union))
+        (cooked-fields (queue:new)))
+    (dotimes (j (length raw-fields))
+      (queue:add cooked-fields
+                 (list (intern (gethash "name" (aref raw-fields j)))
+                       (cook-type (gethash "type" (aref raw-fields j))))))
+    `(sb-alien:union
+       ,(gethash "name" raw-union)
+       ,@(queue:to-list cooked-fields))))
+
+;(defun cook-enum (raw-enum)
+;  (let ((name (gethash (gethash "id" raw-enum) reference-table))
+;        (raw-fields (gethash "fields" raw-enum))
+;        (cooked-fields (queue:new)))
+
+(defstruct spec
+  functions
+  typedefs
+  structs
+  unions
+  enums)
+
+(defun prepare-spec (spec)
+  (clrhash reference-table)
+  (let ((s (make-spec)))
+    (dotimes (i (length spec))
+      (cond ((string= (gethash "tag" (aref spec i)) "function")
+             (push (aref spec i) (spec-functions s)))
+            ((string= (gethash "tag" (aref spec i)) "typedef")
+             (push (aref spec i) (spec-typedefs s)))
+            ((string= (gethash "tag" (aref spec i)) "struct")
+             (push (aref spec i) (spec-structs s)))
+            ((string= (gethash "tag" (aref spec i)) "enum")
+             (push (aref spec i) (spec-enums s)))
+            ((string= (gethash "tag" (aref spec i)) "union")
+             (push (aref spec i) (spec-unions s)))
+            (t)))
+; typedefs must be generated first to build the reference table
+    (setf (spec-typedefs s) (mapcar #'cook-typedef (spec-typedefs s)))
+    (setf (spec-functions s) (mapcar #'cook-function (spec-functions s)))
+    ;(setf (spec-enums s) (mapcar #'cook-enum (spec-enums s)))
+    (setf (spec-structs s)
+          (mapcar (lambda (x)
+                    `(sb-alien:define-alien-type nil ,(cook-struct x)))
+                  (spec-structs s)))
+    (setf (spec-unions s)
+          (mapcar (lambda (x)
+                    `(sb-alien:define-alien-type nil ,(cook-union x)))
+                  (spec-unions s)))
+    s))
+
+(defun to-file (spec filename) 
+  (with-open-file (f filename
+                     :direction :output
+                     :if-exists :overwrite
+                     :if-does-not-exist :create)
+; definitions must be written in the following order to avoid "unknown type" errors
+    (princ ";;; GENERATED BY CMAMUT" f)
+    (terpri f)
+    (princ ";typedefs" f)
+    (terpri f)
+    (format f "~{~s~&~}" (spec-typedefs spec))
+    (princ ";enums" f)
+    (terpri f)
+    (format f "~{~s~&~}" (spec-enums spec))
+    (princ ";structs" f)
+    (terpri f)
+    (format f "~{~s~&~}" (spec-structs spec))
+    (princ ";unions" f)
+    (terpri f)
+    (format f "~{~s~&~}" (spec-unions spec))
+    (princ ";functions" f)
+    (terpri f)
+    (format f "~{~s~&~}" (spec-functions spec))))