8e2bc595c6
Complete the prototype removal in ca1431. The script prevents SWIGTOOL=gdb from working as gdb can't be used to debug a shell script, it requires a binary. Add support for SWIGTOOL in all the examples. SWIG_LIB_DIR and SWIGEXE must now instead be set by all Makefiles. See issue #473.
389 lines
13 KiB
Common Lisp
389 lines
13 KiB
Common Lisp
;;; 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.
|