diff options
| -rw-r--r-- | cmamut.lisp | 142 |
1 files changed, 75 insertions, 67 deletions
diff --git a/cmamut.lisp b/cmamut.lisp index dc62a98..d30821e 100644 --- a/cmamut.lisp +++ b/cmamut.lisp @@ -11,11 +11,11 @@ ; 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 (defvar enum-references (make-hash-table :test #'equal :size 256)) -(defun get-spec () +; 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) @@ -63,7 +63,7 @@ (cook-struct raw-type)) ((string= tag "union") (cook-union raw-type)) - (t tag)))) + (t tag)))) ;TODO: Add type resolution (defun cook-function (raw-function &optional name-transformer) (let ((raw-params (gethash "parameters" raw-function)) @@ -80,15 +80,6 @@ ,(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))) - (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 cook-struct (raw-struct) (let ((raw-fields (gethash "fields" raw-struct)) (cooked-fields (queue:new))) @@ -127,23 +118,20 @@ nil ,@(queue:to-list cooked-fields))))) -(defun filter-base-types (raw-typedefs) - (clrhash type-associations) - (setf (gethash ":char" type-associations) t) - (setf (gethash ":short" type-associations) t) - (setf (gethash ":int" type-associations) t) - (setf (gethash ":long" type-associations) t) - (setf (gethash ":signed-char" type-associations) t) - (setf (gethash ":signed-short" type-associations) t) - (setf (gethash ":signed-int" type-associations) t) - (setf (gethash ":signed-long" type-associations) t) - (setf (gethash ":unsigned-char" type-associations) t) - (setf (gethash ":unsigned-short" type-associations) t) - (setf (gethash ":unsigned-int" type-associations) t) - (setf (gethash ":unsigned-long" type-associations) t) - (setf (gethash ":float" type-associations) t) - (setf (gethash ":double" type-associations) t) - (setf (gethash ":function-pointer" type-associations) t) +; 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))))) + +; Generates a table for type resolution. +; Typedefs get "flattened" so that resolving is just a lookup. +(defun flatten-typedefs (raw-typedefs) + (let ((type-associations (make-hash-table :test #'equal :size 256))) (labels ((take-deps (deps) (let (remaining) @@ -166,7 +154,7 @@ (unless (eq v t) (associate-base-type k v))) type-associations)) - result))) + result)))) (defstruct spec functions @@ -175,41 +163,57 @@ unions enums) -(defun classify-definitions (spec) - (let ((s (make-spec))) - (dotimes (i (length spec)) - (let ((tag (gethash "tag" (aref spec i)))) - (cond ((string= tag "function") - (push (aref spec i) (spec-functions s))) - - ((string= tag "typedef") - (let ((internal-type (gethash "type" (aref spec i)))) - (cond ((string= (gethash "tag" internal-type) "struct") - (when (string= (gethash "name" internal-type) "") - (setf (gethash "name" internal-type) (gethash "name" (aref spec i)))) - (push (gethash "type" (aref spec i)) (spec-structs s)) - (setf (gethash "type" (aref spec i)) - (json:from-string - (format nil - "{ \"tag\": \":struct\", \"name\": ~s }" - (gethash "name" internal-type)))))) - (push (aref spec i) (spec-typedefs s)))) - - ((string= tag "struct") - (push (aref spec i) (spec-structs s))) - ((string= tag "enum") - (push (aref spec i) (spec-enums s))) - ((string= tag "union") - (push (aref spec i) (spec-unions s))) - (t)))) - s)) +; This is done so we can separate definition types into stages when generating code. +; Some crazy shit is happening when processing typedefs so we can identify nested composite types and put them into the right buckets. +; What's left on the typedefs are references to said composite types. +; This allows for a comfier type resolution stage by letting us flatten typedefs. +; Composite types cause problems because they can't be redefined. +(defun classify-definitions (raw-spec) + (let ((spec (make-spec))) + (dotimes (i (length raw-spec)) + (classify-definition (aref raw-spec i) spec)) + spec)) + +(defun classify-definition (def spec) + (let ((tag (gethash "tag" def))) + (cond ((string= tag "function") + (push def (spec-functions spec))) + + ((or (string= tag "typedef") + (string= tag ":array") + (string= tag ":pointer")) + (let* ((internal-type (gethash "type" def)) + (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))) + (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))))) + ((or (string= internal-tag ":array") + (string= internal-tag ":pointer")) + (classify-definition internal-type spec))) + (when (string= tag "typedef") + (push def (spec-typedefs spec))))) + + ((string= tag "struct") + (push def (spec-structs spec))) + ((string= tag "enum") + (push def (spec-enums spec))) + ((string= tag "union") + (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-functions spec) (mapcar #'cook-function (spec-functions spec))) (setf (spec-enums spec) (mapcar #'cook-enum (spec-enums spec))) (setf (spec-structs spec) (mapcar (lambda (x) @@ -219,19 +223,23 @@ (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-file (spec filename) +(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 to-file (code filename) (with-open-file (f filename :direction :output :if-exists :supersede :if-does-not-exist :create) - (princ ";;; GENERATED BY CMAMUT" f) - (terpri f) (let ((*print-length* nil) (*print-level* nil)) - (format f "~{~s~&~}" (spec-enums spec)) - (format f "~{~s~&~}" (spec-typedefs spec))))) -;(format f "~{~s~&~}" (spec-structs spec)) -;(format f "~{~s~&~}" (spec-unions spec)) -;(format f "~{~s~&~}" (spec-functions spec))))) + (format f "~{~s~&~}" code)))) |