/trunk/Examples/s-exp/uffi.lisp
Lisp | 389 lines | 260 code | 35 blank | 94 comment | 1 complexity | 277f511b7033a575b048734d08a629f7 MD5 | raw file
Possible License(s): LGPL-2.1, Cube, GPL-3.0, 0BSD, GPL-2.0
- ;;; This is experimental code that uses the s-expression
- ;;; representation of a C/C++ library interface to generate Foreign
- ;;; Function Interface definitions for use with Kevin Rosenberg's
- ;;; UFFI.
- ;;;
- ;;; Written by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
- (eval-when (:compile-toplevel :load-toplevel :execute)
- (require 'port) ; from CLOCC
- (require 'uffi))
- (in-package :cl-user)
- ;; Interaction with the SWIG binary
- (defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
- (defvar *swig-program* (merge-pathnames "preinst-swig" *swig-source-directory*))
- (defun run-swig (swig-interface-file-name &key directory-search-list module
- ignore-errors c++)
- (let ((temp-file-name "/tmp/swig.lsp"))
- (let ((process
- (port:run-prog (namestring *swig-program*)
- :output t
- :args `(,@(and c++ '("-c++"))
- "-sexp"
- ,@(mapcar (lambda (dir)
- (concatenate 'string
- "-I" (namestring dir)))
- directory-search-list)
- ,@(and module
- `("-module" ,module))
- "-o" ,temp-file-name
- ,(namestring swig-interface-file-name)))))
- #+cmu (unless (or (zerop (ext:process-exit-code process))
- ignore-errors)
- (error "Process swig exited abnormally"))
- (with-open-file (s temp-file-name)
- (read s)))))
- ;; Type system
- (defun parse-swigtype (type-string &key start end junk-ok)
- "Parse TYPE-STRING as SWIG's internal representation of C/C++
- types. Return two values: The type description (an improper list) and
- the terminating index into TYPE-STRING."
- ;; SWIG's internal representation is described in Source/Swig/stype.c
- (unless start
- (setq start 0))
- (unless end
- (setq end (length type-string)))
- (flet ((prefix-match (prefix)
- (let ((position (mismatch prefix type-string :start2 start :end2 end)))
- (or (not position)
- (= position (length prefix)))))
- (bad-type-error (reason)
- (error "Bad SWIG type (~A): ~A" reason
- (subseq type-string start end)))
- (type-char (index)
- (and (< index (length type-string))
- (char type-string index)))
- (cons-and-recurse (prefix start end)
- (multiple-value-bind (type-description index)
- (parse-swigtype type-string :start start :end end
- :junk-ok junk-ok)
- (values (cons prefix type-description)
- index))))
- (cond
- ((prefix-match "p.") ; pointer
- (cons-and-recurse '* (+ start 2) end))
- ((prefix-match "r.") ; C++ reference
- (cons-and-recurse '& (+ start 2) end))
- ((prefix-match "a(") ; array
- (let ((closing-paren (position #\) type-string
- :start (+ start 2)
- :end end)))
- (unless closing-paren
- (bad-type-error "missing right paren"))
- (unless (eql (type-char (+ closing-paren 1)) #\.)
- (bad-type-error "missing dot"))
- (cons-and-recurse (list 'ARRAY (subseq type-string (+ start 2) closing-paren))
- (+ closing-paren 2) end)))
- ((prefix-match "q(") ; qualifier (const, volatile)
- (let ((closing-paren (position #\) type-string
- :start (+ start 2)
- :end end)))
- (unless closing-paren
- (bad-type-error "missing right paren"))
- (unless (eql (type-char (+ closing-paren 1)) #\.)
- (bad-type-error "missing dot"))
- (cons-and-recurse (list 'QUALIFIER (subseq type-string (+ start 2) closing-paren))
- (+ closing-paren 2) end)))
- ((prefix-match "m(") ; C++ member pointer
- (multiple-value-bind (class-type class-end-index)
- (parse-swigtype type-string :junk-ok t
- :start (+ start 2) :end end)
- (unless (eql (type-char class-end-index) #\))
- (bad-type-error "missing right paren"))
- (unless (eql (type-char (+ class-end-index 1)) #\.)
- (bad-type-error "missing dot"))
- (cons-and-recurse (list 'MEMBER-POINTER class-type)
- (+ class-end-index 2) end)))
- ((prefix-match "f(") ; function
- (loop with index = (+ start 2)
- until (eql (type-char index) #\))
- collect (multiple-value-bind (arg-type arg-end-index)
- (parse-swigtype type-string :junk-ok t
- :start index :end end)
- (case (type-char arg-end-index)
- (#\, (setq index (+ arg-end-index 1)))
- (#\) (setq index arg-end-index))
- (otherwise (bad-type-error "comma or right paren expected")))
- arg-type)
- into arg-types
- finally (unless (eql (type-char (+ index 1)) #\.)
- (bad-type-error "missing dot"))
- (return (cons-and-recurse (cons 'FUNCTION arg-types)
- (+ index 2) end))))
- ((prefix-match "v(") ;varargs
- (let ((closing-paren (position #\) type-string
- :start (+ start 2)
- :end end)))
- (unless closing-paren
- (bad-type-error "missing right paren"))
- (values (list 'VARARGS (subseq type-string (+ start 2) closing-paren))
- (+ closing-paren 1))))
- (t (let ((junk-position (position-if (lambda (char)
- (member char '(#\, #\( #\) #\.)))
- type-string
- :start start :end end)))
- (cond (junk-position ; found junk
- (unless junk-ok
- (bad-type-error "trailing junk"))
- (values (subseq type-string start junk-position)
- junk-position))
- (t
- (values (subseq type-string start end)
- end))))))))
- (defun swigtype-function-p (swigtype)
- "Check whether SWIGTYPE designates a function. If so, the second
- value is the list of argument types, and the third value is the return
- type."
- (if (and (consp swigtype)
- (consp (first swigtype))
- (eql (first (first swigtype)) 'FUNCTION))
- (values t (rest (first swigtype)) (rest swigtype))
- (values nil nil nil)))
-
- ;; UFFI
- (defvar *uffi-definitions* '())
- (defconstant *uffi-default-primitive-type-alist*
- '(("char" . :char)
- ("unsigned char" . :unsigned-byte)
- ("signed char" . :byte)
- ("short" . :short)
- ("signed short" . :short)
- ("unsigned short" . :unsigned-short)
- ("int" . :int)
- ("signed int" . :int)
- ("unsigned int" . :unsigned-int)
- ("long" . :long)
- ("signed long" . :long)
- ("unsigned long" . :unsigned-long)
- ("float" . :float)
- ("double" . :double)
- ((* . "char") . :cstring)
- ((* . "void") . :pointer-void)
- ("void" . :void)))
- (defvar *uffi-primitive-type-alist* *uffi-default-primitive-type-alist*)
- (defun uffi-type-spec (type-list)
- "Return the UFFI type spec equivalent to TYPE-LIST, or NIL if there
- is no representation."
- (let ((primitive-type-pair
- (assoc type-list *uffi-primitive-type-alist* :test 'equal)))
- (cond
- (primitive-type-pair
- (cdr primitive-type-pair))
- ((and (consp type-list)
- (eql (first type-list) '*))
- (let ((base-type-spec (uffi-type-spec (rest type-list))))
- (cond
- ((not base-type-spec)
- :pointer-void)
- (t
- (list '* base-type-spec)))))
- (t nil))))
- ;; Parse tree
- (defvar *uffi-output* nil)
- (defun emit-uffi-definition (uffi-definition)
- (format *uffi-output* "~&~S~%" uffi-definition)
- (push uffi-definition *uffi-definitions*))
- (defun make-cl-symbol (c-identifier &key uninterned)
- (let ((name (substitute #\- #\_ (string-upcase c-identifier))))
- (if uninterned
- (make-symbol name)
- (intern name))))
- (defvar *class-scope* '() "A stack of names of nested C++ classes.")
- (defvar *struct-fields* '())
- (defvar *linkage* :C "NIL or :C")
- (defgeneric handle-node (node-type &key &allow-other-keys)
- (:documentation "Handle a node of SWIG's parse tree of a C/C++ program"))
- (defmethod handle-node ((node-type t) &key &allow-other-keys)
- ;; do nothing for unknown node types
- nil)
- (defmethod handle-node ((node-type (eql 'cdecl)) &key name decl storage parms type &allow-other-keys)
- (let ((swigtype (parse-swigtype (concatenate 'string decl type))))
- (let ((*print-pretty* nil) ; or FUNCTION would be printed as #' by cmucl
- (*print-circle* t))
- (format *uffi-output* "~&;; C Declaration: ~A ~A ~A ~A~%;; with-parms ~W~%;; of-type ~W~%"
- storage type name decl parms swigtype))
- (multiple-value-bind (function-p arg-swigtype-list return-swigtype)
- (swigtype-function-p swigtype)
- (declare (ignore arg-swigtype-list))
- (cond
- ((and (null *class-scope*) function-p
- (or (eql *linkage* :c)
- (string= storage "externc")))
- ;; ordinary top-level function with C linkage
- (let ((argnum 0)
- (argname-list '()))
- (flet ((unique-argname (name)
- ;; Sometimes the functions in SWIG interfaces
- ;; do not have unique names. Make them unique
- ;; by adding a suffix. Also avoid symbols
- ;; that are specially bound.
- (unless name
- (setq name (format nil "arg~D" argnum)))
- (let ((argname (make-cl-symbol name)))
- (when (boundp argname) ;specially bound
- (setq argname (make-cl-symbol name :uninterned t)))
- (push argname argname-list)
- argname)))
- (let ((uffi-arg-list
- (mapcan (lambda (param)
- (incf argnum)
- (destructuring-bind (&key name type &allow-other-keys) param
- (let ((uffi-type (uffi-type-spec (parse-swigtype type))))
- (cond
- ((not uffi-type)
- (format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
- type name)
- (return-from handle-node))
- ((eq uffi-type :void)
- '())
- (t
- (let ((symbol (unique-argname name)))
- (list `(,symbol ,uffi-type))))))))
- parms))
- (uffi-return-type
- (uffi-type-spec return-swigtype)))
- (unless uffi-return-type
- (format *uffi-output* "~&;; Warning: Cannot handle return type `~S'~%"
- return-swigtype)
- (return-from handle-node))
- (emit-uffi-definition `(UFFI:DEF-FUNCTION ,name ,uffi-arg-list :RETURNING ,uffi-return-type))))))
- ((and (not (null *class-scope*)) (null (rest *class-scope*))
- (not function-p)) ; class/struct member (no nested structs)
- (let ((uffi-type (uffi-type-spec swigtype)))
- (unless uffi-type
- (format *uffi-output* "~&;; Warning: Cannot handle type ~S of struct field `~A'~%"
- type name)
- (return-from handle-node))
- (push `(,(make-cl-symbol name) ,uffi-type) *struct-fields*)))))))
- (defmethod handle-node ((node-type (eql 'class)) &key name children kind &allow-other-keys)
- (format *uffi-output* "~&;; Class ~A~%" name)
- (let ((*class-scope* (cons name *class-scope*))
- (*struct-fields* '()))
- (dolist (child children)
- (apply 'handle-node child))
- (emit-uffi-definition `(,(if (string= kind "union")
- 'UFFI:DEF-UNION
- 'UFFI:DEF-STRUCT)
- ,(make-cl-symbol name) ,@(nreverse *struct-fields*)))))
- (defmethod handle-node ((node-type (eql 'top)) &key children &allow-other-keys)
- (dolist (child children)
- (apply 'handle-node child)))
-
- (defmethod handle-node ((node-type (eql 'include)) &key name children &allow-other-keys)
- (format *uffi-output* ";; INCLUDE ~A~%" name)
- (dolist (child children)
- (apply 'handle-node child)))
- (defmethod handle-node ((node-type (eql 'extern)) &key name children &allow-other-keys)
- (format *uffi-output* ";; EXTERN \"C\" ~A~%" name)
- (let ((*linkage* :c))
- (dolist (child children)
- (apply 'handle-node child))))
- ;;(defun compute-uffi-definitions (swig-interface)
- ;; (let ((*uffi-definitions* '()))
- ;; (handle-node swig-interface)
- ;; *uffi-definitions*))
- ;; Test instances
- ;;; Link to SWIG itself
- #||
- (defparameter *c++-compiler* "g++")
- (defun stdc++-library (&key env)
- (let ((error-output (make-string-output-stream)))
- (let ((name-output (make-string-output-stream)))
- (let ((proc (ext:run-program
- *c++-compiler*
- '("-print-file-name=libstdc++.so")
- :env env
- :input nil
- :output name-output
- :error error-output)))
- (unless proc
- (error "Could not run ~A" *c++-compiler*))
- (unless (zerop (ext:process-exit-code proc))
- (system:serve-all-events 0)
- (error "~A failed:~%~A" *c++-compiler*
- (get-output-stream-string error-output))))
- (string-right-trim '(#\Newline) (get-output-stream-string name-output)))))
- (defvar *swig-interface* nil)
- (defvar *swig-uffi-pathname* #p"/tmp/swig-uffi.lisp")
- (defun link-swig ()
- (setq *swig-interface*
- (run-swig (merge-pathnames "Source/swig.i" *swig-source-directory*)
- :directory-search-list
- (list (merge-pathnames "Source/" *swig-source-directory*))
- :module "swig"
- :ignore-errors t
- :c++ t))
- (with-open-file (f *swig-uffi-pathname* :direction :output)
- (let ((*linkage* :c++)
- (*uffi-definitions* '())
- (*uffi-output* f)
- (*uffi-primitive-type-alist* *uffi-default-primitive-type-alist*))
- (apply 'handle-node *swig-interface*)))
- (compile-file *swig-uffi-pathname*)
- (alien:load-foreign (merge-pathnames "Source/libswig.a"
- *swig-source-directory*)
- :libraries (list (stdc++-library)))
- ;; FIXME: UFFI stuffes a "-l" in front of the passed library names
- ;; (uffi:load-foreign-library (merge-pathnames "Source/libswig.a"
- ;; *swig-source-directory*)
- ;; :supporting-libraries
- ;; (list (stdc++-library)))
- (load (compile-file-pathname *swig-uffi-pathname*)))
- ||#
- ;;;; TODO:
- ;; * How to do type lookups? Is everything important that SWIG knows
- ;; about the types written out? What to make of typemaps?
- ;;
- ;; * Wrapped functions should probably automatically COERCE their
- ;; arguments (as of type DOUBLE-FLOAT), to make the functions more
- ;; flexible?
- ;;
- ;; * Why are the functions created by FFI interpreted?
- ;;
- ;; * We can't deal with more complicated structs and C++ classes
- ;; directly with the FFI; we have to emit SWIG wrappers that access
- ;; those classes.
- ;;
- ;; * A CLOS layer where structure fields are mapped as slots. It
- ;; looks like we need MOP functions to implement this.
- ;;
- ;; * Maybe modify SWIG so that key-value hashes are distinguished from
- ;; value-value hashes.