;;; Copyright 2006 Daniel Dickison (danieldickison@cmu.edu) (in-package :c2ffi) (export '(ffi-generator ffi-name ffi-xml-file ffi-output-file ffi-bindings generate-bindings write-bindings)) (defclass ffi-generator () ((name :initarg :name :initform "FFI" :accessor ffi-name :documentation "The type of FFI, used for creating the output path.") (xml-file :initarg :xml-file :initform nil :accessor ffi-xml-file :documentation "The input file generated by GCC-XML.") (output-file :initarg :output-file :initform nil :accessor ffi-output-file :documentation "The output file, which will be computed from the xml-file name if nil.") (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 :documentation "Holds a list of FFI binding forms after calling generate-bindings.")) (:documentation "This class encapsulates the generation of FFI bindings from XML files generated by GCC-XML.")) (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) (aand (probe-file (ffi-xml-file ffi)) (make-pathname :name (pathname-name it) :type "lisp" :directory (append (pathname-directory it) (list :up (ffi-name ffi))) :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 :before ((ffi-gen ffi-generator)) (format *terminal-io* "~&Generating ~A bindings.~%" (ffi-name ffi-gen))) (: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 :before ((ffi-gen ffi-generator) &key &allow-other-keys) (format *terminal-io* "~&Writing bindings to ~S.~%" (ffi-output-file ffi-gen))) (: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*)) "Generates a Lisp name in the form of a symbol from a given C-style name by replacing underscores with dashes, uppercasing, then interning the symbol." (intern (string-upcase (string-replace (string str) "_" "-" :all t)) package))