| ;;; 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 "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. |