Added FFI-Generator and CFFI-Generator CLOS classes
Mon Sep 4 18:43:42 PDT 2006 Daniel Dickison (danieldickison@gmail.com)
* Added FFI-Generator and CFFI-Generator CLOS classes
diff -rN -u old-c2ffi/C-to-FFI.lisp new-c2ffi/C-to-FFI.lisp
--- old-c2ffi/C-to-FFI.lisp 2014-07-31 04:31:07.000000000 -0700
+++ new-c2ffi/C-to-FFI.lisp 2014-07-31 04:31:07.000000000 -0700
@@ -8,6 +8,8 @@
eval-defs
write-defs))
+
+
(defun make-uffi-for-files (dir &key gcc-options-file (in-package *package*))
(format *terminal-io* "~&~%Running: ~S~%Options: ~S~%" *gccxml-command-path* (truename gcc-options-file))
(dolist (infile (directory dir))
diff -rN -u old-c2ffi/CFFI-Generator.lisp new-c2ffi/CFFI-Generator.lisp
--- old-c2ffi/CFFI-Generator.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-c2ffi/CFFI-Generator.lisp 2014-07-31 04:31:07.000000000 -0700
@@ -0,0 +1,93 @@
+(in-package :c2ffi)
+
+(export '(cffi-generator))
+
+(defclass cffi-generator (ffi-generator)
+ ())
+
+(defmethod sort-bindings ((ffi cffi-generator))
+ (setf (slot-value ffi 'bindings)
+ (sort (ffi-bindings ffi)
+ #'<
+ :key #'(lambda (form)
+ (ecase (car form)
+ (export 0)
+ (cffi:defctype 1)
+ (cffi:defcenum 2)
+ (cffi:defcunion 3)
+ (cffi:defcstruct 4)
+ (cffi:defcfun 5))))))
+
+(defmethod bindings-for-node ((ffi cffi-generator)
+ (type (eql :Function))
+ node)
+ (let* ((c-name (name-with-id ffi (node-attribute "id" node) nil))
+ (lisp-name (str->sym c-name)))
+ (list*
+ `(cffi:defcfun (,c-name ,lisp-name)
+ ,(type-with-id ffi (node-attribute "returns" node))
+ ,@(mapcar #'(lambda (arg-node)
+ (list
+ (str->sym (node-attribute "name" arg-node))
+ (type-with-id ffi (node-attribute "type" arg-node))))
+ (find-in-tree node "Argument" () :all t)))
+ (when (aand (node-attribute "extern" node)
+ (string= it "1"))
+ `((export ',lisp-name))))))
+
+(defmethod bindings-for-node ((ffi cffi-generator)
+ (type (eql :Typedef))
+ node)
+ (let ((lisp-name (name-with-id ffi (node-attribute "id" node))))
+ (list
+ `(cffi:defctype ,lisp-name
+ ,(type-with-id ffi (node-attribute "type" node)))
+ `(export ',lisp-name))))
+
+(defmethod bindings-for-node ((ffi cffi-generator)
+ (type (eql :Enumeration))
+ node)
+ (let ((lisp-name (name-with-id ffi (node-attribute "id" node))))
+ (list
+ `(cffi:defcenum ,lisp-name
+ ,@(mapcar #'(lambda (val-node)
+ (list
+ (str->sym (node-attribute "name" val-node) :keyword)
+ (parse-integer (node-attribute "init" val-node))))
+ (find-in-tree node "EnumValue" () :all t)))
+ `(export ',lisp-name))))
+
+(defmethod bindings-for-node ((ffi cffi-generator)
+ (type (eql :Struct))
+ node)
+ (cffi-struct-union-bindings ffi type node 'cffi:defcstruct))
+
+(defmethod bindings-for-node ((ffi cffi-generator)
+ (type (eql :Union))
+ node)
+ (cffi-struct-union-bindings ffi type node 'cffi:defcunion))
+
+(defun cffi-struct-union-bindings (ffi type node func)
+ (let* ((lisp-name (name-with-id ffi (node-attribute "id" node)))
+ (root-node (ffi-parse-tree ffi))
+ (field-ids (split-sequence #\space (node-attribute "members" node)
+ :remove-empty-subseqs t))
+ (field-nodes (mapcan #'(lambda (id)
+ (awhen (find-in-tree root-node "Field" `(("id" ,id)))
+ (list it)))
+ field-ids)))
+ (list
+ `(,func ,lisp-name
+ ,@(mapcar #'(lambda (field-node)
+ (when (node-attribute "bits" field-node)
+ (warn "Array fields in structs/unions not currently supported~% In struct: ~S~% field: ~S" node field-node))
+ (list*
+ (str->sym (node-attribute "name" field-node))
+ (type-with-id ffi (node-attribute "type" field-node))
+ (awhen (and (eql type :Struct)
+ (node-attribute "offset" field-node))
+ (list :offset (parse-integer it)))))
+ field-nodes))
+ `(export ',lisp-name))))
+
+
\ No newline at end of file
diff -rN -u old-c2ffi/FFI-Generator.lisp new-c2ffi/FFI-Generator.lisp
--- old-c2ffi/FFI-Generator.lisp 1969-12-31 16:00:00.000000000 -0800
+++ new-c2ffi/FFI-Generator.lisp 2014-07-31 04:31:07.000000000 -0700
@@ -0,0 +1,263 @@
+;;; Copyright 2006 Daniel Dickison (danieldickison@cmu.edu)
+
+(in-package :c2ffi)
+
+(export '(ffi-generator
+ ffi-xml-file
+ ffi-output-file
+ ffi-parse-tree
+ ffi-bindings
+ generate-bindings
+ write-bindings))
+
+
+
+(defclass ffi-generator ()
+ ((xml-file :initarg :xml-file
+ :initform nil
+ :accessor ffi-xml-file)
+ (output-file :initarg :output-file
+ :initform nil
+ :accessor ffi-output-file)
+ (parse-tree :type list
+ :initarg :parse-tree
+ :initform nil
+ :accessor ffi-parse-tree)
+ (name-mappings :initform (make-hash-table :test #'equal)
+ :reader ffi-name-mappings)
+ (type-mappings :initform (make-hash-table :test #'equal)
+ :reader ffi-type-mappings)
+ (bindings :type list :initform nil
+ :reader ffi-bindings)))
+
+(defmethod ffi-output-file ((ffi ffi-generator))
+ "Override the accessor getter for output-file to return a value computed from xml-file if this slot is not explicitly set."
+ (or (slot-value ffi 'output-file)
+ (and (ffi-xml-file ffi)
+ (make-pathname :type "lisp"
+ :defaults (ffi-xml-file ffi)))
+ (error "Output file cannot be determined. Please set either xml-file or output-file.")))
+
+(defgeneric generate-bindings (ffi-gen)
+ (:documentation "Generates bindings from the XML-File, if the slot is set, or from the parse-tree. If neither XML-File or parse-tree is set, an error is signalled.")
+ (:method ((ffi-gen ffi-generator))
+ (with-slots (xml-file parse-tree) ffi-gen
+ (assert (or xml-file parse-tree) (xml-file parse-tree)
+ "Either an XML-File or a non-empty parse-tree must be set for the FFI-Generator ~A." ffi-gen)
+ (when xml-file
+ (parse-xml ffi-gen))
+ (make-id-mappings ffi-gen)
+ (make-ffi-bindings ffi-gen)
+ (ffi-bindings ffi-gen))))
+
+
+(defgeneric write-bindings (ffi-gen
+ &key in-package if-exists if-does-not-exist)
+ (:documentation "Writes the generated bindings out to output-file.")
+ (:method ((ffi ffi-generator)
+ &key
+ (in-package nil)
+ (if-exists :error)
+ (if-does-not-exist :create))
+ (unless (ffi-bindings ffi)
+ (generate-bindings ffi))
+ (ensure-directories-exist (ffi-output-file ffi))
+ (with-open-file (stream (ffi-output-file ffi)
+ :direction :output
+ :if-exists if-exists
+ :if-does-not-exist if-does-not-exist)
+ (let ((*print-length* nil)
+ (*print-level* nil)
+ (*print-readably* t)
+ (*print-escape* t)
+ (*print-pretty* t))
+ (when in-package
+ (print `(in-package ,(if (packagep in-package)
+ (package-name in-package)
+ in-package))
+ stream))
+ (dolist (form (ffi-bindings ffi))
+ (print form stream))))))
+
+
+(defgeneric parse-xml (ffi-gen)
+ (:documentation "Parses an XML file created by GCC-XML and sets FFI-GEN's parse-tree slot to a Lisp tree as generated by XMLS. The XML-File slot must be set.")
+ (:method ((ffi-gen ffi-generator))
+ (with-open-file (stream (ffi-xml-file ffi-gen))
+ (setf (ffi-parse-tree ffi-gen) (xmls:parse stream)))))
+
+(defgeneric make-id-mappings (ffi-gen)
+ (:documentation "Creates name and type-mappings from FFI-GEN's parse-tree.")
+ (:method ((ffi-gen ffi-generator))
+ (with-slots ((names name-mappings)
+ (types type-mappings)
+ (tree parse-tree))
+ ffi-gen
+ (clrhash names)
+ (clrhash types)
+ (let ((id nil)
+ (prev-node nil))
+ (do-nodes-df (node tree)
+ (setf id (node-attribute "id" node))
+ (when id
+ (awhen (gethash id names)
+ (error "Duplicate ID ~S (~A)." id it))
+ (setf (gethash id names)
+ (if (aand (node-attribute "artificial" node)
+ (string= it "1"))
+ (node-attribute "name" prev-node)
+ (node-attribute "name" node)))
+ (awhen (translate-type ffi-gen
+ (str->sym (node-name node) :keyword)
+ node prev-node)
+ (setf (gethash id types) it)))
+ (setf prev-node node))))))
+
+(defgeneric make-ffi-bindings (ffi-gen)
+ (:documentation "Sets the bindings slot to a list of FFI bindings.")
+ (:method ((ffi-gen ffi-generator))
+ (let ((ignore-files (files-to-ignore ffi-gen)))
+ (setf (slot-value ffi-gen 'bindings)
+ (mapcan #'(lambda (node)
+ (unless (member (node-attribute "file" node)
+ ignore-files :test #'equal)
+ (bindings-for-node ffi-gen
+ (str->sym (node-name node) :keyword)
+ node)))
+ (node-children (ffi-parse-tree ffi-gen))))
+ (sort-bindings ffi-gen))))
+
+(defgeneric name-with-id (ffi-gen id &optional as-symbol)
+ (:documentation "Returns a name associated with ID. This is necessary when a struct or union (and others?) are defined artificially, in which case the 'name' attribute of a node is a placeholder, and there is a corresponding typedef that names the type.")
+ (:method ((ffi ffi-generator) id &optional (as-symbol t))
+ (let ((name (or (gethash id (ffi-name-mappings ffi))
+ (error "Name with ID ~S not found." id))))
+ (if as-symbol (str->sym name) name))))
+
+(defgeneric type-with-id (ffi-gen id)
+ (:documentation "Returns the FFI type for the given id string. This tracks down any necessary references.")
+ (:method ((ffi ffi-generator) id)
+ (multiple-value-bind
+ (entry exists?) (gethash id (ffi-type-mappings ffi))
+ (unless exists?
+ (error "Type with ID ~S not found." id))
+ (etypecase entry
+ (list (mapcar #'(lambda (token)
+ (if (stringp token)
+ (type-with-id ffi token)
+ token))
+ entry))
+ (string (type-with-id ffi entry))
+ (symbol entry)))))
+
+(defgeneric translate-type (ffi-gen type-key node prev-node)
+ (:documentation "Translates a C typedef to an FFI type. Returns nil if node is not a type definition, a symbol or list if it is a direct type, or a string ID if it is equivalent to a different type. Type-key should be a keyword symbol of the node type.")
+
+ ;; Non-typedef nodes return nil.
+ (:method ((ffi ffi-generator) (type t) node prev-node)
+ (declare (ignore node prev-node))
+ nil)
+
+ ;; These are the built-in types, so intern keyword symbols.
+ ;; Note 1: double is substituted for long double except for scl.
+ ;; Note 2: complex float/double/long double are ignored.
+ (:method ((ffi ffi-generator) (type (eql :FundamentalType))
+ node prev-node)
+ (declare (ignore prev-node))
+ (let ((name (node-attribute "name" node)))
+ ;; Ignore complex *.
+ (when (string-find name "complex")
+ (return-from translate-type nil))
+
+ ;; Strip trailing "int" if it starts with a "long".
+ (when (string-find name "long")
+ (setf name (string-replace name " int" "")))
+
+ ;; Substitute double for long double.
+ #-:scl
+ (when (string= name "long double")
+ (setf name "double"))
+
+ ;; Make it a keyword symbol.
+ (str->sym (string-replace name " " "-" :all t) :keyword)))
+
+ ;; These are the typedefs, so just intern the name.
+ (:method ((ffi ffi-generator) (type (eql :Typedef))
+ node prev-node)
+ (declare (ignore prev-node))
+ (str->sym (node-attribute "name" node)))
+
+ ;; These are const-specified types, so just refer to the plain-vanilla type.
+ (:method ((ffi ffi-generator) (type (eql :CvQualifiedType))
+ node prev-node)
+ (declare (ignore prev-node))
+ (node-attribute "type" node)) ;This returns the ID of the relevant type.
+
+ ;; Pointers: we discard the type info and return :pointer.
+ (:method ((ffi ffi-generator) (type (eql :PointerType))
+ node prev-node)
+ (declare (ignore node prev-node))
+ :pointer)
+
+ ;; Same with function pointers.
+ (:method ((ffi ffi-generator) (type (eql :FunctionType))
+ node prev-node)
+ (declare (ignore node prev-node))
+ :pointer)
+
+ ;; Structs, Unions and Enums can be "artificial", in which case we need the previous node's ID.
+ (:method ((ffi ffi-generator) (type (eql :Struct))
+ node prev-node)
+ (if (aand (node-attribute "artificial" node)
+ (string= it "1"))
+ (node-attribute "id" prev-node)
+ (str->sym (node-attribute "name" node))))
+
+ (:method ((ffi ffi-generator) (type (eql :Union))
+ node prev-node)
+ (if (aand (node-attribute "artificial" node)
+ (string= it "1"))
+ (node-attribute "id" prev-node)
+ (str->sym (node-attribute "name" node))))
+
+ (:method ((ffi ffi-generator) (type (eql :Enumeration))
+ node prev-node)
+ (if (aand (node-attribute "artificial" node)
+ (string= it "1"))
+ (node-attribute "id" prev-node)
+ (str->sym (node-attribute "name" node)))))
+
+
+(defgeneric files-to-ignore (ffi-gen)
+ (:documentation "GCC-XML includes standard definitions from its own header files. These should probably be ignored. This method returns a list of files IDs to ignore.")
+ (:method ((ffi-gen ffi-generator))
+ (let ((files (find-in-tree (ffi-parse-tree ffi-gen)
+ "File" () :all t)))
+ (iter
+ (for file in files)
+ (when (string-find (node-attribute "name" file)
+ "gccxml")
+ (collect (node-attribute "id" file)))))))
+
+(defgeneric bindings-for-node (ffi-gen type-key node)
+ (:documentation "Returns a list of FFI binding forms for node. Type-key should be a keyword symbol of the node type")
+ (:method ((ffi ffi-generator) (type t) node)
+ (declare (ignore node))
+ nil))
+
+(defgeneric sort-bindings (ffi-gen)
+ (:documentation "Sorts the FFI bindings so that prerequisite definitions are before where they are needed. I'm not sure what to do about recursive relationships in structs and unions... is this even possible? Email danieldickison@gmail.com if you have any insight.")
+ (:method ((ffi ffi-generator))
+ (ffi-bindings ffi)))
+
+
+
+
+
+;;;;; Utility ;;;;;
+(defun str->sym (str &optional (package *package*))
+ (intern (string-upcase (string-replace (string str) "_" "-"))
+ package))
+
+
+
diff -rN -u old-c2ffi/c2ffi.asd new-c2ffi/c2ffi.asd
--- old-c2ffi/c2ffi.asd 2014-07-31 04:31:07.000000000 -0700
+++ new-c2ffi/c2ffi.asd 2014-07-31 04:31:07.000000000 -0700
@@ -1,8 +1,7 @@
(defsystem "c2ffi"
- :author "Daniel Dickison (danieldickison@cmu.edu)"
+ :author "Daniel Dickison (danieldickison@gmail.com)"
:version "0.1"
- :depends-on ("xmls" "cl-utilities" "iterate" "anaphora" "string-utilities"
- #-:ecl "uffi")
+ :depends-on ("xmls" "cl-utilities" "iterate" "anaphora")
:components ((:file "Package")
(:file "Pathnames"
:depends-on ("Package"))
@@ -12,8 +11,19 @@
:depends-on ("Package" "String-Utilities"))
(:file "GCC-XML"
:depends-on ("Package" "Pathnames"))
- (:file "C-to-FFI"
- :depends-on ("Pathnames" "Package" "GCC-XML"
- "XML-Utilities" "String-Utilities"))
- (:file "UFFI-Generator"
- :depends-on ("Package" "C-to-FFI"))))
+ (:file "FFI-Generator"
+ :depends-on ("Package" "String-Utilities" "XML-Utilities"))))
+; (:file "CFFI-Generator"
+; :depends-on ("Package" "FFI-Generator"))))
+;
+; (:file "C-to-FFI"
+; :depends-on ("Pathnames" "Package" "GCC-XML"
+; "XML-Utilities" "String-Utilities"))
+; (:file "UFFI-Generator"
+; :depends-on ("Package" "C-to-FFI"))))
+
+(defsystem "c2ffi-cffi"
+ :author "Daniel Dickison (danieldickison@gmail.com)"
+ :version "0.1"
+ :depends-on ("c2ffi" "xmls" "cl-utilities" "anaphora" "cffi")
+ :components ((:file "CFFI-Generator")))