The great merge

git-svn-id: https://swig.svn.sourceforge.net/svnroot/swig/trunk@4141 626c5289-ae23-0410-ae9c-e8d60b6d4f22

SWIG/Examples/s-exp/uffi.lisp

@@ -0,0 +1,349 @@
+;;; 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>
+
+(require 'port)				; from CLOCC
+
+(in-package :cl-user)
+
+(require 'uffi)
+
+;; Interaction with the SWIG binary
+
+(defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
+
+(defvar *swig-program* (merge-pathnames "swig-1.3" *swig-source-directory*))
+
+(defun run-swig (swig-interface-file-name &key directory-search-list module
+		 ignore-errors)
+  (setf (port:getenv :SWIG_LIB)
+	(namestring (merge-pathnames "Lib" *swig-source-directory*)))
+  (let ((temp-file-name "/tmp/swig.lsp"))
+    (let ((process
+	   (port:run-prog (namestring *swig-program*)
+			  :output t
+			  :args `("-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 (find #\) 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 (find #\) 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))))
+      (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)
+  (intern (substitute #\- #\_ (string-upcase c-identifier))))
+
+(defvar *class-scope* '() "A stack of names of nested C++ classes.")
+
+(defvar *struct-fields* '())
+
+(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
+      (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) ; ordinary top-level function
+	 (let ((uffi-arg-list
+		(mapcar (lambda (param)
+			  (destructuring-bind (&key name type &allow-other-keys) param
+			    (let ((uffi-type (uffi-type-spec (parse-swigtype type))))
+			      (unless uffi-type
+				(format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
+					type name)
+				(return-from handle-node))
+			      `(,(make-cl-symbol name) ,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)))
+  
+;;(defun compute-uffi-definitions (swig-interface)
+;;  (let ((*uffi-definitions* '()))
+;;    (handle-node swig-interface)
+;;    *uffi-definitions*))
+
+;; Test instances
+
+#+ignore
+(defvar *gifplot-interface*
+  (run-swig (merge-pathnames "Examples/GIFPlot/Interface/gifplot.i"
+			     *swig-source-directory*)
+	    :directory-search-list (list (merge-pathnames "Examples/GIFPlot/Interface/" *swig-source-directory*))))
+
+(defvar *simple-gifplot-interface*
+  (run-swig (merge-pathnames "Examples/GIFPlot/Include/gifplot.h"
+			     *swig-source-directory*)
+	    :directory-search-list (list (merge-pathnames "Examples/GIFPlot/Interface/" *swig-source-directory*))
+	    :module "gifplot"))
+
+(defvar *cplex-glue-directory* #p"/home/mkoeppe/cvs/cplex-glue/")
+
+(defvar *cplex-glue-interface*
+  (run-swig (merge-pathnames "cplex.i" *cplex-glue-directory*)
+	    :directory-search-list (list (merge-pathnames "Lib/guile"
+							  *swig-source-directory*)
+					 *cplex-glue-directory*)
+	    :ignore-errors t))
+	    
+  
+
+(require 'uffi)
+
+;;(let ((*uffi-primitive-type-alist* (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
+;;  (eval (cons 'progn (compute-uffi-definitions *simple-gifplot-interface*))))
+
+
+(with-open-file (f "/tmp/swig-uffi.lisp" :direction :output)
+  (let ((*uffi-definitions* '())
+	(*uffi-output* f)
+	(*uffi-primitive-type-alist*
+	 (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
+    (apply 'handle-node *simple-gifplot-interface*)))
+
+#+cplex
+(with-open-file (f "/tmp/swig-uffi.lisp" :direction :output)
+  (let ((*uffi-definitions* '())
+	(*uffi-output* f)
+	(*uffi-primitive-type-alist*
+	 (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
+    (apply 'handle-node *cplex-glue-interface*)))
+
+(compile-file "/tmp/swig-uffi.lisp")
+
+(load "/tmp/swig-uffi.lisp")
+
+(uffi:load-foreign-library (merge-pathnames "Examples/GIFPlot/libgifplot.a"
+					    *swig-source-directory*))
+
+(load (merge-pathnames "Examples/GIFPlot/Common-Lisp/full/runme.lisp" *swig-source-directory*))
+
+(action (namestring (merge-pathnames "Examples/GIFPlot/Common-Lisp/full/cmap"
+				     *swig-source-directory*)))
+
+;;;; 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.