diff options
Diffstat (limited to 'cmamut.lisp')
| -rw-r--r-- | cmamut.lisp | 275 |
1 files changed, 162 insertions, 113 deletions
diff --git a/cmamut.lisp b/cmamut.lisp index e608c25..4191085 100644 --- a/cmamut.lisp +++ b/cmamut.lisp @@ -2,11 +2,14 @@ (defparameter +target-package+ (gensym)) +; TODO: Create a C parser so I don't rely on c2ffi. +; TODO: Process the header files directly in memory. (defun get-raw-spec (filename search-directories) - (sb-ext:run-program "/usr/bin/c2ffi" (list filename - "--macro-file" "defines.h" - "--with-macro-defs" - "--output" "spec.json")) + (sb-ext:run-program "/usr/local/bin/c2ffi" + (list filename + "--macro-file" "defines.h" + "--with-macro-defs" + "--output" "spec.json")) (let ((tmp (make-string-output-stream))) (with-open-file (in "defines.h") (loop :for ln = (read-line in nil) @@ -15,8 +18,9 @@ (format tmp "~a~&~a~&" (read-line in) (read-line in))))) (with-open-file (out "defines.h" :direction :output :if-exists :supersede) (format out "~a" (get-output-stream-string tmp)))) - (sb-ext:run-program "/usr/bin/c2ffi" '("defines.h" - "--output" "defines.json")) + (sb-ext:run-program "/usr/local/bin/c2ffi" + (list "defines.h" + "--output" "defines.json")) (let ((spec (json:from-file "spec.json")) (defines (json:from-file "defines.json"))) (delete-file "spec.json") @@ -24,61 +28,82 @@ (delete-file "defines.h") (concatenate 'vector defines spec))) -; TODO: Handle different sizes of enum -(defun cook-type (raw-type type-associations) +(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") - 'sb-alien:void) + :void) ((string= tag ":function-pointer") - (list 'sb-alien:* t)) + :pointer) ((string= tag ":pointer") (let ((pointed-type (gethash "type" raw-type))) (cond ((string= (gethash "tag" pointed-type) ":char") - 'sb-alien:c-string) + :string) ((string= (gethash "tag" pointed-type) ":void") - (list 'sb-alien:* t)) - (t (list 'sb-alien:* (cook-type pointed-type type-associations)))))) + :pointer) + (t (list :pointer (define-argument + (cook-type pointed-type type-associations name-transformer))))))) ((string= tag ":float") - 'sb-alien:float) + :float) ((or (string= tag ":double") (string= tag ":long-double")) - 'sb-alien:double) - ((or (string= tag ":unsigned-char") (string= tag ":_Bool")) - 'sb-alien:unsigned-char) + :double) + ((string= tag ":_Bool") + :bool) + ((string= tag ":unsigned-char") + :unsigned-char) ((string= tag ":unsigned-short") - 'sb-alien:unsigned-short) + :unsigned-short) ((string= tag ":unsigned-int") - 'sb-alien:unsigned-int) + :unsigned-int) ((string= tag ":unsigned-long") - 'sb-alien:unsigned-long) + :unsigned-long) ((string= tag ":unsigned-long-long") - 'sb-alien:unsigned-long-long) + :unsigned-long-long) ((or (string= tag ":char") (string= tag ":signed-char")) - 'sb-alien:char) + :char) ((or (string= tag ":short") (string= tag ":signed-short")) - 'sb-alien:short) + :short) ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<)) - 'sb-alien:int) + :int) ((or (string= tag ":long") (string= tag ":signed-long")) - 'sb-alien:long) + :long) ((or (string= tag ":long-long") (string= tag ":signed-long-long")) - 'sb-alien:long-long) + :long-long) ((string= tag ":array") - (list 'sb-alien:array - (cook-type (gethash "type" raw-type) type-associations) + (list :array (cook-type (gethash "type" raw-type) type-associations name-transformer) + :count (gethash "size" raw-type))) ((string= tag ":struct") - (list 'sb-alien:struct (intern (gethash "name" raw-type) +target-package+))) + (list :struct (intern (funcall name-transformer (gethash "name" raw-type) :composite) + +target-package+))) ((string= tag ":union") - (list 'sb-alien:union (intern (gethash "name" raw-type) +target-package+))) + (list :union (intern (funcall name-transformer (gethash "name" raw-type) :composite) + +target-package+))) ((string= tag ":enum") - 'sb-alien:int) + :int) ((or (string= tag "struct") (string= tag "union")) - (cook-composite raw-type type-associations)) + (cons :struct + (cdr (cook-composite raw-type type-associations name-transformer)))) ((string= tag "__builtin_va_list") - (list 'sb-alien:* t)) + :pointer) (t (let ((new-type (gethash tag type-associations))) (if new-type - (cook-type new-type type-associations) + (cook-type new-type type-associations name-transformer) (error "Unknown type: ~a" tag))))))) (defun cook-function (raw-function type-associations name-transformer) @@ -88,24 +113,34 @@ (queue:add cooked-params (list (if (string= (gethash "name" (aref raw-params j)) "") (gensym) - (intern (gethash "name" (aref raw-params j)) +target-package+)) - (cook-type (gethash "type" (aref raw-params j)) type-associations)))) - `(sb-alien:define-alien-routine + (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 ,(let ((function-name (gethash "name" raw-function))) (list function-name (intern (funcall name-transformer function-name :function) +target-package+))) - ,(cook-type (gethash "return-type" raw-function) type-associations) + ,(define-argument + (cook-type (gethash "return-type" raw-function) type-associations name-transformer)) ,@(queue:to-list cooked-params)))) -(defun cook-composite (raw-composite type-associations) +(defun cook-composite (raw-composite type-associations name-transformer) (let ((raw-fields (gethash "fields" raw-composite)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) (queue:add cooked-fields - (list (intern (string-upcase (gethash "name" (aref raw-fields j))) 'keyword) - (cook-type (gethash "type" (aref raw-fields j)) type-associations)))) - `(,(intern (string-upcase (gethash "tag" raw-composite)) 'sb-alien) - ,(when (> (length (gethash "name" raw-composite)) 0) - (intern (gethash "name" raw-composite) +target-package+)) + (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) + ,(intern (funcall name-transformer (gethash "name" raw-composite) :composite) + +target-package+) ,@(queue:to-list cooked-fields)))) (defun cook-const (raw-const name-transformer) @@ -122,7 +157,8 @@ (dotimes (j (length raw-fields)) (queue:add cooked-fields `(defconstant - ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const) +target-package+) + ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const) + +target-package+) ,(gethash "value" (aref raw-fields j))))) `(progn ,name @@ -143,12 +179,11 @@ (let ((type-associations (make-hash-table :test #'equal :size 256))) (dolist (i raw-typedefs) (setf (gethash (gethash "name" i) type-associations) (gethash "type" i))) - (labels ((flatten-typedef - (k v) - (let ((new-v (gethash (gethash "tag" v) type-associations))) - (when new-v - (setf (gethash k type-associations) new-v) - (flatten-typedef k new-v))))) + (labels ((flatten-typedef (k v) + (let ((new-v (gethash (gethash "tag" v) type-associations))) + (when new-v + (setf (gethash k type-associations) new-v) + (flatten-typedef k new-v))))) (maphash #'flatten-typedef type-associations)) type-associations)) @@ -159,6 +194,7 @@ composite enums) +; TODO: Sort the entries alphabetically, to increase consistency of generated files. ; This is done so we can separate definition types into stages when generating code. ; When processing typedefs we need to identify nested composite types and put them into the right buckets. ; What's left on the typedefs are references to said composite types. @@ -185,8 +221,7 @@ (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))) + (setf (gethash "name" internal-type) (gethash "name" def)) (push internal-type (spec-composite spec)) (setf (gethash "type" def) (json:obj ("tag" (gethash "tag" internal-type)) @@ -204,43 +239,58 @@ (push def (spec-composite spec))))) spec) -(defun gather-composite-dependencies (composite) - (let ((names (make-hash-table))) - (labels ((get-deps - (def) - (dolist (param (cddr def)) - (let ((param-type (cadr param))) - (when (listp param-type) - (cond ((or (eql (car param-type) 'sb-alien:struct) - (eql (car param-type) 'sb-alien:union)) - (setf (gethash (cadr param-type) names) t) - (get-deps param-type)) - ((and (eql (car param-type) 'sb-alien:array) - (listp (cadr param-type))) - (setf (gethash (caadr param-type) names) t) - (get-deps (cadr param-type))))))))) - (get-deps composite)) - names)) +(defun find-dependency (field-type type-associations) + (let* ((type-assoc (gethash (gethash "tag" field-type) + type-associations)) + (inner-type (or type-assoc field-type)) + (type-tag (gethash "tag" inner-type))) + (cond ((or (string= type-tag ":struct") + (string= type-tag "struct") + (string= type-tag ":union") + (string= type-tag "union")) + (gethash "name" inner-type)) + ((or (string= type-tag ":pointer") + (string= type-tag ":array")) + (find-dependency (gethash "type" inner-type) + type-associations)) + (t nil)))) -(defun sort-composites-by-deps (composites) - (let ((comps-and-deps (mapcar (lambda (x) - (cons x (gather-composite-dependencies x))) - composites)) - (result nil)) - (labels ((filter-deps - (cnd) - (let ((new-cnd (remove-if (lambda (x) (= (hash-table-count (cdr x)) 0)) cnd))) - (if (= (length new-cnd) (length cnd)) - result - (progn - (dolist (i cnd) - (when (= (hash-table-count (cdr i)) 0) - (push (car i) result) - (dolist (j new-cnd) - (remhash (second (car i)) (cdr j))))) - (filter-deps new-cnd)))))) - (filter-deps comps-and-deps)) - (reverse result))) +(defun gather-dependencies (raw-composite type-associations) + (let ((result nil) + (fields (gethash "fields" raw-composite))) + (dotimes (i (length fields)) + (let* ((field-type (gethash "type" (aref fields i))) + (dependency (find-dependency field-type type-associations))) + (if dependency + (push dependency result)))) + (cons raw-composite result))) + +; Composites need to be defined in a partial ordering so dependencies are satisfied. +(defun sort-composites (raw-composites type-associations) + (labels ((partial-sort (leaves roots) + (if roots + (let ((new-leaves (mapcar + (lambda (x) (car x)) + (remove-if + (lambda (x) (> (length x) 1)) + roots))) + (new-roots (remove-if + (lambda (x) (= (length x) 1)) + roots))) + (dolist (i new-leaves) + (let ((leaf-name (gethash "name" i))) + (dolist (j new-roots) + (delete leaf-name j :test #'equal)))) + (partial-sort (concatenate 'list + leaves + new-leaves) + new-roots)) + leaves))) + (let ((result (partial-sort nil + (mapcar (lambda (x) + (gather-dependencies x type-associations)) + raw-composites)))) + result))) (defun codegen (spec name-transformer) (let ((enum-references (generate-enum-references (spec-typedefs spec))) @@ -249,39 +299,37 @@ (spec-consts spec))) (enums (mapcar (lambda (x) (cook-enum x enum-references name-transformer)) (spec-enums spec))) - (composite (mapcar (lambda (x) - `(sb-alien:define-alien-type - ,(intern (funcall name-transformer (symbol-name (cadr x)) :composite) - +target-package+) - ,x)) - (sort-composites-by-deps - (mapcar (lambda (x) (cook-composite x type-associations)) - (spec-composite spec))))) + (composite (mapcar (lambda (x) (cook-composite x type-associations name-transformer)) + (sort-composites (spec-composite spec) + type-associations))) (functions (mapcar (lambda (x) (cook-function x type-associations name-transformer)) (spec-functions spec)))) (remove-duplicates (concatenate 'list consts enums composite functions) :test #'equal)))) -; TODO: Export only the transformed symbols +; TODO: Generate a lisp file for every header file. +; TODO: Generate a file for the shared objects. +; TODO: Create an asd file referencing the generated files. (defun to-file (code filename pkg-name shared-object) + (with-open-file (f "package.lisp" + :direction :output + :if-exists nil) + (format f "(DEFPACKAGE #:~a~& (:EXPORT" pkg-name) + (let ((*package* (find-package +target-package+))) + (do-symbols (s *package*) (format f "~& #:~s" s))) + (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)))) (with-open-file (f filename :direction :output - :if-exists :supersede - :if-does-not-exist :create) + :if-exists nil) (let ((*print-length* nil) (*print-level* nil) - (*print-pretty* t) (*package* (find-package +target-package+))) - (when pkg-name - (format f "(COMMON-LISP:DEFPACKAGE #:~a~& (:EXPORT" (string-upcase pkg-name)) - (do-symbols (s *package*) (format f "~& #:~s" s)) - (format f "))~&(COMMON-LISP:IN-PACKAGE #:~a)~&" (string-upcase pkg-name))) - (when shared-object - (let ((loaded? (intern "LOADED?" +target-package+))) - (format f - "~s~&" - `(let ((,loaded? nil)) - (sb-alien:load-shared-object ,shared-object) - (setf ,loaded? t))))) + (format f "(COMMON-LISP:IN-PACKAGE #:~a)~&" pkg-name) (format f "~{~s~&~}" code)))) (defun filter-directories (search-directories raw-spec) @@ -302,7 +350,8 @@ (str:upcase->pascal (str:underscore->hyphen name))))))) -(defun run (header-file &key package-name shared-object additional-directories name-transformer) +; TODO: Handle multiple header files and shared objects. +(defun generate-bindings (package-name &key header-file shared-object additional-directories name-transformer) (unless (probe-file header-file) (error (format t "The header file ~a doesn't exist!" header-file))) (when (not (find-package +target-package+)) |