(parse-swigtype): Handle varargs.

When generating arg lists, avoid globally bound names.

Handle `extern "C"' nodes.

Add experimental code to link to SWIG itself.


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

SWIG/Examples/s-exp/uffi.lisp

@@ -5,12 +5,12 @@
 ;;;
 ;;; Written by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
 
-(require 'port)				; from CLOCC
+(eval-when (:compile-toplevel :load-toplevel :execute)
+  (require 'port)				; from CLOCC
+  (require 'uffi))
 
 (in-package :cl-user)
 
-(require 'uffi)
-
 ;; Interaction with the SWIG binary
 
 (defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
@@ -18,14 +18,15 @@
 (defvar *swig-program* (merge-pathnames "swig" *swig-source-directory*))
 
 (defun run-swig (swig-interface-file-name &key directory-search-list module
-		 ignore-errors)
+		 ignore-errors c++)
   (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"
+			  :args `(,@(and c++ '("-c++"))
+				  "-sexp"
 				  ,@(mapcar (lambda (dir)
 				       (concatenate 'string
 						    "-I" (namestring dir)))
@@ -118,6 +119,14 @@ the terminating index into TYPE-STRING."
 		       (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
@@ -193,13 +202,18 @@ is no representation."
   (format *uffi-output* "~&~S~%" uffi-definition)
   (push uffi-definition *uffi-definitions*))
 
-(defun make-cl-symbol (c-identifier)
+(defun make-cl-symbol (c-identifier &key uninterned)
-  (intern (substitute #\- #\_ (string-upcase c-identifier))))
+  (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* nil "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"))
 
@@ -209,32 +223,55 @@ is no representation."
 
 (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
+    (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) ; ordinary top-level function
+	((and (null *class-scope*) function-p
-	 (let ((uffi-arg-list
+	      (or (eql *linkage* :c)
-		(mapcar (lambda (param)
+		  (string= storage "externc")))
-			  (destructuring-bind (&key name type &allow-other-keys) param
+	 ;; ordinary top-level function with C linkage
-			    (let ((uffi-type (uffi-type-spec (parse-swigtype type))))
+	 (let ((argnum 0)
-			      (unless uffi-type
+	       (argname-list '()))
-				(format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
+	   (flet ((unique-argname (name)
-					type name)
+		    ;; Sometimes the functions in SWIG interfaces
-				(return-from handle-node))
+		    ;; do not have unique names.  Make them unique
-			      `(,(make-cl-symbol name) ,uffi-type))))
+		    ;; by adding a suffix.  Also avoid symbols
-			parms))
+		    ;; that are specially bound.
-	       (uffi-return-type
+		    (unless name
-		(uffi-type-spec return-swigtype)))
+		      (setq name (format nil "arg~D" argnum)))
-	   (unless uffi-return-type
+		    (let ((argname (make-cl-symbol name)))
-	     (format *uffi-output* "~&;; Warning: Cannot handle return type `~S'~%"
+		      (when (boundp argname) ;specially bound
-		     return-swigtype)
+			(setq argname (make-cl-symbol name :uninterned t)))
-	     (return-from handle-node))
+		      (push argname argname-list)
-	   (emit-uffi-definition `(UFFI:DEF-FUNCTION ,name ,uffi-arg-list :RETURNING ,uffi-return-type))))
+		      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)))
@@ -263,7 +300,13 @@ is no representation."
   (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)
@@ -271,6 +314,8 @@ is no representation."
 
 ;; Test instances
 
+#||
+
 #+ignore
 (defvar *gifplot-interface*
   (run-swig (merge-pathnames "Examples/GIFPlot/Interface/gifplot.i"
@@ -327,6 +372,58 @@ is no representation."
 (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 ((*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