1 files changed, 450 insertions, 0 deletions
diff --git a/Examples/s-exp/uffi.lisp b/Examples/s-exp/uffi.lisp
new file mode 100644
index 0000000..5ddb4c2
--- /dev/null
+++ b/Examples/s-exp/uffi.lisp
@@ -0,0 +1,450 @@
+;;; 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
+
+#||
+
+#+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
+		   :if-exists :supersede)
+  (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")
+
+(uffi:load-foreign-library (merge-pathnames "Examples/GIFPlot/libgifplot.a"
+					    *swig-source-directory*))
+
+(load "/tmp/swig-uffi.lisp")
+
+(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*)))
+
+||#
+
+;;; 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.