diff options
| -rw-r--r-- | cmamut.lisp | 88 |
1 files changed, 43 insertions, 45 deletions
diff --git a/cmamut.lisp b/cmamut.lisp index 9918c5d..a5133a0 100644 --- a/cmamut.lisp +++ b/cmamut.lisp @@ -12,13 +12,11 @@ ; TODO: Get constants from macro file generated by c2ffi -M -(defvar enum-references (make-hash-table :test #'equal :size 256)) - ; 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 cook-type (raw-type) +(defun cook-type (raw-type type-associations) (let ((tag (gethash "tag" raw-type))) (cond ((string= tag ":void") 'sb-alien:void) @@ -30,7 +28,7 @@ 'sb-alien:c-string) ((string= (gethash "tag" pointed-type) ":void") (list 'sb-alien:* t)) - (t (list 'sb-alien:* (cook-type pointed-type)))))) + (t (list 'sb-alien:* (cook-type pointed-type type-associations)))))) ((string= tag ":float") 'sb-alien:float) ((string= tag ":double") @@ -53,7 +51,7 @@ 'sb-alien:long) ((string= tag ":array") (list 'sb-alien:array - (cook-type (gethash "type" raw-type)) + (cook-type (gethash "type" raw-type) type-associations) (gethash "size" raw-type))) ((string= tag ":struct") (list 'sb-alien:struct (intern (gethash "name" raw-type)))) @@ -63,48 +61,51 @@ (cook-struct raw-type)) ((string= tag "union") (cook-union raw-type)) - (t tag)))) ;TODO: Add type resolution + (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 &optional name-transformer) +(defun cook-function (raw-function type-associations &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 (string-upcase (gethash "name" (aref raw-params j)))) - (cook-type (gethash "type" (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))) (if name-transformer (list function-name (funcall name-transformer function-name)) function-name)) - ,(cook-type (gethash "return-type" raw-function)) + ,(cook-type (gethash "return-type" raw-function) type-associations) ,@(queue:to-list cooked-params)))) -(defun cook-struct (raw-struct) +(defun cook-struct (raw-struct type-associations) (let ((raw-fields (gethash "fields" raw-struct)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) (queue:add cooked-fields (list (intern (string-upcase (gethash "name" (aref raw-fields j)))) - (cook-type (gethash "type" (aref raw-fields j)))))) + (cook-type (gethash "type" (aref raw-fields j)) type-associations)))) `(sb-alien:struct ,(when (> (length (gethash "name" raw-struct)) 0) (intern (gethash "name" raw-struct))) ,@(queue:to-list cooked-fields)))) -(defun cook-union (raw-union) +(defun cook-union (raw-union type-associations) (let ((raw-fields (gethash "fields" raw-union)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) (queue:add cooked-fields (list (intern (string-upcase (gethash "name" (aref raw-fields j)))) - (cook-type (gethash "type" (aref raw-fields j)))))) + (cook-type (gethash "type" (aref raw-fields j)) type-associations)))) `(sb-alien:union ,(when (> (length (gethash "name" raw-union)) 0) (intern (gethash "name" raw-union))) ,@(queue:to-list cooked-fields)))) -(defun cook-enum (raw-enum) +(defun cook-enum (raw-enum enum-references) (let ((name (gethash (gethash "id" raw-enum) enum-references)) (raw-fields (gethash "fields" raw-enum)) (cooked-fields (queue:new))) @@ -118,21 +119,22 @@ nil ,@(queue:to-list cooked-fields))))) -; If the enum table population gets done at an earlier stage and all typedefs get flattened, there would be no need of having codegen for typedefs. -(defun cook-typedef (raw-typedef) - (let* ((base-type (gethash "type" raw-typedef)) - (new-name (gethash "name" raw-typedef))) - (if (string= (gethash "tag" base-type) ":enum") - (progn (setf (gethash (gethash "id" base-type) enum-references) new-name) nil) - `(sb-alien:define-alien-type - ,new-name - ,(cook-type base-type))))) +(defun generate-enum-references (raw-typedefs) + (let ((enum-references (make-hash-table :test #'equal :size 256))) + (dolist (i raw-typedefs) + (let ((base-type (gethash "type" i))) + (when (string= (gethash "tag" base-type) ":enum") + (setf (gethash (gethash "id" base-type) enum-references) + (gethash "name" i))))) + enum-references)) ; Generates a table for type resolution. ; Typedefs get "flattened" so that resolving is just a lookup. -(defun flatten-typedefs (raw-typedefs) +(defun generate-type-associations (raw-typedefs) (let ((type-associations (make-hash-table :test #'equal :size 256))) (dolist (i raw-typedefs) + (when (string= (gethash "tag" (gethash "type" i)) ":enum") + (setf (gethash "name" (gethash "type" i)) (gethash "name" i))) (setf (gethash (gethash "name" i) type-associations) (gethash "type" i))) (labels ((flatten-typedef (k v) @@ -177,11 +179,8 @@ (setf (gethash "name" internal-type) (gethash "name" def))) (classify-definition internal-type spec) (setf (gethash "type" def) - (json:from-string - (format nil - "{ \"tag\": \":~a\", \"name\": ~s }" - (gethash "tag" internal-type) - (gethash "name" internal-type))))) + (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))) @@ -196,22 +195,21 @@ (push def (spec-unions spec))))) spec) -(defun codegen (spec) - (clrhash enum-references) - ; typedefs must be generated first to build the reference table - (setf (spec-typedefs spec) - (remove nil (mapcar #'cook-typedef (filter-base-types (spec-typedefs spec))))) - (setf (spec-enums spec) (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 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 |