diff options
Diffstat (limited to 'cmamut.lisp')
| -rw-r--r-- | cmamut.lisp | 120 |
1 files changed, 48 insertions, 72 deletions
diff --git a/cmamut.lisp b/cmamut.lisp index 4191085..094e2da 100644 --- a/cmamut.lisp +++ b/cmamut.lisp @@ -28,79 +28,61 @@ (delete-file "defines.h") (concatenate 'vector defines spec))) -(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") - :void) + 'sb-alien:void) ((string= tag ":function-pointer") - :pointer) + (list 'sb-alien:* t)) ((string= tag ":pointer") (let ((pointed-type (gethash "type" raw-type))) (cond ((string= (gethash "tag" pointed-type) ":char") - :string) + 'sb-alien:c-string) ((string= (gethash "tag" pointed-type) ":void") - :pointer) - (t (list :pointer (define-argument - (cook-type pointed-type type-associations name-transformer))))))) + (list 'sb-alien:* t)) + (t (list 'sb-alien:* (cook-type pointed-type type-associations name-transformer)))))) ((string= tag ":float") - :float) + 'sb-alien:float) ((or (string= tag ":double") (string= tag ":long-double")) - :double) + 'sb-alien:double) ((string= tag ":_Bool") - :bool) + 'sb-alien:unsigned-char) ((string= tag ":unsigned-char") - :unsigned-char) + 'sb-alien:unsigned-char) ((string= tag ":unsigned-short") - :unsigned-short) + 'sb-alien:unsigned-short) ((string= tag ":unsigned-int") - :unsigned-int) + 'sb-alien:unsigned-int) ((string= tag ":unsigned-long") - :unsigned-long) + 'sb-alien:unsigned-long) ((string= tag ":unsigned-long-long") - :unsigned-long-long) + 'sb-alien:unsigned-long-long) ((or (string= tag ":char") (string= tag ":signed-char")) - :char) + 'sb-alien:char) ((or (string= tag ":short") (string= tag ":signed-short")) - :short) + 'sb-alien:short) ((or (string= tag ":int") (string= tag ":signed-int") (char= (char tag 0) #\<)) - :int) + 'sb-alien:int) ((or (string= tag ":long") (string= tag ":signed-long")) - :long) + 'sb-alien:long) ((or (string= tag ":long-long") (string= tag ":signed-long-long")) - :long-long) + 'sb-alien:long-long) ((string= tag ":array") - (list :array (cook-type (gethash "type" raw-type) type-associations name-transformer) - :count + (list 'sb-alien:array (cook-type (gethash "type" raw-type) type-associations name-transformer) (gethash "size" raw-type))) ((string= tag ":struct") - (list :struct (intern (funcall name-transformer (gethash "name" raw-type) :composite) - +target-package+))) + (list 'sb-alien:struct (intern (funcall name-transformer (gethash "name" raw-type) :composite) + +target-package+))) ((string= tag ":union") - (list :union (intern (funcall name-transformer (gethash "name" raw-type) :composite) - +target-package+))) + (list 'sb-alien:union (intern (funcall name-transformer (gethash "name" raw-type) :composite) + +target-package+))) ((string= tag ":enum") - :int) + 'sb-alien:int) ((or (string= tag "struct") (string= tag "union")) - (cons :struct - (cdr (cook-composite raw-type type-associations name-transformer)))) + (cook-composite raw-type type-associations name-transformer)) ((string= tag "__builtin_va_list") - :pointer) + (list 'sb-alien:* t)) (t (let ((new-type (gethash tag type-associations))) (if new-type (cook-type new-type type-associations name-transformer) @@ -110,15 +92,15 @@ (let ((raw-params (gethash "parameters" raw-function)) (cooked-params (queue:new))) (dotimes (j (length raw-params)) - (queue:add cooked-params - (list (if (string= (gethash "name" (aref raw-params j)) "") - (gensym) - (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 + (queue:push (list (if (string= (gethash "name" (aref raw-params j)) "") + (gensym) + (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))) + cooked-params)) + `(sb-alien:define-alien-routine ,(let ((function-name (gethash "name" raw-function))) (list function-name (intern (funcall name-transformer function-name :function) +target-package+))) ,(define-argument @@ -129,16 +111,13 @@ (let ((raw-fields (gethash "fields" raw-composite)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) - (queue:add cooked-fields - (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) + (queue:push (define-field + (intern (string-upcase (gethash "name" (aref raw-fields j))) + 'keyword) + (cook-type (gethash "type" (aref raw-fields j)) type-associations name-transformer)) + cooked-fields)) + `(,(find-symbol (string-upcase (gethash "tag" raw-composite)) + 'sb-alien) ,(intern (funcall name-transformer (gethash "name" raw-composite) :composite) +target-package+) ,@(queue:to-list cooked-fields)))) @@ -155,11 +134,11 @@ (raw-fields (gethash "fields" raw-enum)) (cooked-fields (queue:new))) (dotimes (j (length raw-fields)) - (queue:add cooked-fields - `(defconstant - ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const) - +target-package+) - ,(gethash "value" (aref raw-fields j))))) + (queue:push `(defconstant + ,(intern (funcall name-transformer (gethash "name" (aref raw-fields j)) :const) + +target-package+) + ,(gethash "value" (aref raw-fields j))) + cooked-fields)) `(progn ,name ,@(queue:to-list cooked-fields)))) @@ -319,10 +298,7 @@ (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)))) + `(load-shared-object ,shared-object)))) (with-open-file (f filename :direction :output :if-exists nil) |