PageRenderTime 52ms CodeModel.GetById 29ms app.highlight 18ms RepoModel.GetById 1ms app.codeStats 0ms

/trunk/Examples/s-exp/uffi.lisp

#
Lisp | 389 lines | 260 code | 35 blank | 94 comment | 1 complexity | 277f511b7033a575b048734d08a629f7 MD5 | raw file
  1;;; This is experimental code that uses the s-expression
  2;;; representation of a C/C++ library interface to generate Foreign
  3;;; Function Interface definitions for use with Kevin Rosenberg's
  4;;; UFFI.
  5;;;
  6;;; Written by Matthias Koeppe <mkoeppe@mail.math.uni-magdeburg.de>
  7
  8(eval-when (:compile-toplevel :load-toplevel :execute)
  9  (require 'port)				; from CLOCC
 10  (require 'uffi))
 11
 12(in-package :cl-user)
 13
 14;; Interaction with the SWIG binary
 15
 16(defvar *swig-source-directory* #p"/home/mkoeppe/s/swig1.3/")
 17
 18(defvar *swig-program* (merge-pathnames "preinst-swig" *swig-source-directory*))
 19
 20(defun run-swig (swig-interface-file-name &key directory-search-list module
 21		 ignore-errors c++)
 22  (let ((temp-file-name "/tmp/swig.lsp"))
 23    (let ((process
 24	   (port:run-prog (namestring *swig-program*)
 25			  :output t
 26			  :args `(,@(and c++ '("-c++"))
 27				  "-sexp"
 28				  ,@(mapcar (lambda (dir)
 29				       (concatenate 'string
 30						    "-I" (namestring dir)))
 31					    directory-search-list)
 32				  ,@(and module
 33					 `("-module" ,module))
 34				  "-o" ,temp-file-name
 35				  ,(namestring swig-interface-file-name)))))
 36      #+cmu (unless (or (zerop (ext:process-exit-code process))
 37			ignore-errors)
 38	      (error "Process swig exited abnormally"))
 39      (with-open-file (s temp-file-name)
 40	(read s)))))
 41
 42;; Type system
 43
 44(defun parse-swigtype (type-string &key start end junk-ok)
 45  "Parse TYPE-STRING as SWIG's internal representation of C/C++
 46types. Return two values: The type description (an improper list) and
 47the terminating index into TYPE-STRING."
 48  ;; SWIG's internal representation is described in Source/Swig/stype.c
 49  (unless start
 50    (setq start 0))
 51  (unless end
 52    (setq end (length type-string)))
 53  (flet ((prefix-match (prefix)
 54	   (let ((position (mismatch prefix type-string :start2 start :end2 end)))
 55	     (or (not position)
 56		 (= position (length prefix)))))
 57	 (bad-type-error (reason)
 58	   (error "Bad SWIG type (~A): ~A" reason
 59		  (subseq type-string start end)))
 60	 (type-char (index)
 61	   (and (< index (length type-string))
 62		(char type-string index)))	       
 63	 (cons-and-recurse (prefix start end)
 64	   (multiple-value-bind (type-description index)
 65	       (parse-swigtype type-string :start start :end end
 66				:junk-ok junk-ok)
 67	     (values (cons prefix type-description)
 68		     index))))
 69    (cond
 70      ((prefix-match "p.")		; pointer
 71       (cons-and-recurse '* (+ start 2) end))
 72      ((prefix-match "r.")		; C++ reference
 73       (cons-and-recurse '& (+ start 2) end))
 74      ((prefix-match "a(")		; array
 75       (let ((closing-paren (position #\) type-string
 76				  :start (+ start 2)
 77				  :end end)))
 78	 (unless closing-paren
 79	   (bad-type-error "missing right paren"))
 80	 (unless (eql (type-char (+ closing-paren 1)) #\.)
 81	   (bad-type-error "missing dot"))
 82	 (cons-and-recurse (list 'ARRAY (subseq type-string (+ start 2) closing-paren))
 83			   (+ closing-paren 2) end)))
 84      ((prefix-match "q(")		; qualifier (const, volatile)
 85       (let ((closing-paren (position #\) type-string
 86				  :start (+ start 2)
 87				  :end end)))
 88	 (unless closing-paren
 89	   (bad-type-error "missing right paren"))
 90	 (unless (eql (type-char (+ closing-paren 1)) #\.)
 91	   (bad-type-error "missing dot"))
 92	 (cons-and-recurse (list 'QUALIFIER (subseq type-string (+ start 2) closing-paren))
 93			   (+ closing-paren 2) end)))
 94      ((prefix-match "m(")		; C++ member pointer
 95       (multiple-value-bind (class-type class-end-index)
 96	   (parse-swigtype type-string :junk-ok t
 97			    :start (+ start 2) :end end)
 98	 (unless (eql (type-char class-end-index) #\))
 99	   (bad-type-error "missing right paren"))
100	 (unless (eql (type-char (+ class-end-index 1)) #\.)
101	   (bad-type-error "missing dot"))
102	 (cons-and-recurse (list 'MEMBER-POINTER class-type)
103			   (+ class-end-index 2) end)))	 
104      ((prefix-match "f(")		; function
105       (loop with index = (+ start 2) 
106	     until (eql (type-char index) #\))
107	     collect (multiple-value-bind (arg-type arg-end-index)
108			 (parse-swigtype type-string :junk-ok t
109					  :start index :end end)
110		       (case (type-char arg-end-index)
111			 (#\, (setq index (+ arg-end-index 1)))
112			 (#\) (setq index arg-end-index))
113			 (otherwise (bad-type-error "comma or right paren expected"))) 
114		       arg-type)
115	     into arg-types
116	     finally (unless (eql (type-char (+ index 1)) #\.)
117		       (bad-type-error "missing dot"))
118	     (return (cons-and-recurse (cons 'FUNCTION arg-types)
119				       (+ index 2) end))))
120      ((prefix-match "v(")		;varargs
121       (let ((closing-paren (position #\) type-string
122				  :start (+ start 2)
123				  :end end)))
124	 (unless closing-paren
125	   (bad-type-error "missing right paren"))
126	 (values (list 'VARARGS (subseq type-string (+ start 2) closing-paren))
127		 (+ closing-paren 1))))
128      (t (let ((junk-position (position-if (lambda (char)
129					     (member char '(#\, #\( #\) #\.)))
130					   type-string
131					   :start start :end end)))
132	   (cond (junk-position		; found junk
133		  (unless junk-ok
134		    (bad-type-error "trailing junk"))
135		  (values (subseq type-string start junk-position)
136			  junk-position))
137		 (t
138		  (values (subseq type-string start end)
139			  end))))))))
140
141(defun swigtype-function-p (swigtype)
142  "Check whether SWIGTYPE designates a function.  If so, the second
143value is the list of argument types, and the third value is the return
144type."
145  (if (and (consp swigtype)
146	   (consp (first swigtype))
147	   (eql (first (first swigtype)) 'FUNCTION))
148      (values t (rest (first swigtype)) (rest swigtype))
149      (values nil nil nil)))
150	      
151
152;; UFFI
153
154(defvar *uffi-definitions* '())
155
156(defconstant *uffi-default-primitive-type-alist*
157  '(("char" . :char)
158    ("unsigned char" . :unsigned-byte)
159    ("signed char" . :byte)
160    ("short" . :short)
161    ("signed short" . :short)
162    ("unsigned short" . :unsigned-short)
163    ("int" . :int)
164    ("signed int" . :int)
165    ("unsigned int" . :unsigned-int)
166    ("long" . :long)
167    ("signed long" . :long)
168    ("unsigned long" . :unsigned-long)
169    ("float" . :float)
170    ("double" . :double)
171    ((* . "char") . :cstring)
172    ((* . "void") . :pointer-void)
173    ("void" . :void)))
174
175(defvar *uffi-primitive-type-alist* *uffi-default-primitive-type-alist*)
176
177(defun uffi-type-spec (type-list)
178  "Return the UFFI type spec equivalent to TYPE-LIST, or NIL if there
179is no representation."
180  (let ((primitive-type-pair
181	 (assoc type-list *uffi-primitive-type-alist* :test 'equal)))
182    (cond
183      (primitive-type-pair
184       (cdr primitive-type-pair))
185      ((and (consp type-list)
186	    (eql (first type-list) '*))
187       (let ((base-type-spec (uffi-type-spec (rest type-list))))
188	 (cond
189	   ((not base-type-spec)
190	    :pointer-void)
191	   (t
192	    (list '* base-type-spec)))))
193      (t nil))))
194
195;; Parse tree
196
197(defvar *uffi-output* nil)
198
199(defun emit-uffi-definition (uffi-definition)
200  (format *uffi-output* "~&~S~%" uffi-definition)
201  (push uffi-definition *uffi-definitions*))
202
203(defun make-cl-symbol (c-identifier &key uninterned)
204  (let ((name (substitute #\- #\_ (string-upcase c-identifier))))
205    (if uninterned
206	(make-symbol name)
207	(intern name))))
208
209(defvar *class-scope* '() "A stack of names of nested C++ classes.")
210
211(defvar *struct-fields* '())
212
213(defvar *linkage* :C "NIL or :C")
214
215(defgeneric handle-node (node-type &key &allow-other-keys)
216  (:documentation "Handle a node of SWIG's parse tree of a C/C++ program"))
217
218(defmethod handle-node ((node-type t) &key &allow-other-keys)
219  ;; do nothing for unknown node types
220  nil)
221
222(defmethod handle-node ((node-type (eql 'cdecl)) &key name decl storage parms type &allow-other-keys)
223  (let ((swigtype (parse-swigtype (concatenate 'string decl type))))
224    (let ((*print-pretty* nil) ; or FUNCTION would be printed as #' by cmucl
225	  (*print-circle* t))
226      (format *uffi-output* "~&;; C Declaration: ~A ~A ~A ~A~%;;  with-parms ~W~%;;   of-type ~W~%"
227	      storage type name decl parms swigtype))
228    (multiple-value-bind (function-p arg-swigtype-list return-swigtype)
229	(swigtype-function-p swigtype)
230      (declare (ignore arg-swigtype-list))
231      (cond
232	((and (null *class-scope*) function-p
233	      (or (eql *linkage* :c)
234		  (string= storage "externc")))
235	 ;; ordinary top-level function with C linkage
236	 (let ((argnum 0)
237	       (argname-list '()))
238	   (flet ((unique-argname (name)
239		    ;; Sometimes the functions in SWIG interfaces
240		    ;; do not have unique names.  Make them unique
241		    ;; by adding a suffix.  Also avoid symbols
242		    ;; that are specially bound.
243		    (unless name
244		      (setq name (format nil "arg~D" argnum)))
245		    (let ((argname (make-cl-symbol name)))
246		      (when (boundp argname) ;specially bound
247			(setq argname (make-cl-symbol name :uninterned t)))
248		      (push argname argname-list)
249		      argname)))
250	     (let ((uffi-arg-list
251		    (mapcan (lambda (param)
252			      (incf argnum)
253			      (destructuring-bind (&key name type &allow-other-keys) param
254				(let ((uffi-type (uffi-type-spec (parse-swigtype type))))
255				  (cond
256				    ((not uffi-type)
257				     (format *uffi-output* "~&;; Warning: Cannot handle type ~S of argument `~A'~%"
258					     type name)
259				     (return-from handle-node))
260				    ((eq uffi-type :void)
261				     '())
262				    (t
263				     (let ((symbol (unique-argname name)))
264				       (list `(,symbol ,uffi-type))))))))
265			    parms))
266		   (uffi-return-type
267		    (uffi-type-spec return-swigtype)))
268	       (unless uffi-return-type
269		 (format *uffi-output* "~&;; Warning: Cannot handle return type `~S'~%"
270			 return-swigtype)
271		 (return-from handle-node))
272	       (emit-uffi-definition `(UFFI:DEF-FUNCTION ,name ,uffi-arg-list :RETURNING ,uffi-return-type))))))
273	((and (not (null *class-scope*)) (null (rest *class-scope*))
274	      (not function-p))	; class/struct member (no nested structs)
275	 (let ((uffi-type (uffi-type-spec swigtype)))
276	   (unless  uffi-type
277	     (format *uffi-output* "~&;; Warning: Cannot handle type ~S of struct field `~A'~%"
278		     type name)
279	     (return-from handle-node))
280	   (push `(,(make-cl-symbol name) ,uffi-type) *struct-fields*)))))))
281
282(defmethod handle-node ((node-type (eql 'class)) &key name children kind &allow-other-keys)
283  (format *uffi-output* "~&;; Class ~A~%" name)
284  (let ((*class-scope* (cons name *class-scope*))
285	(*struct-fields* '()))
286    (dolist (child children)
287      (apply 'handle-node child))
288    (emit-uffi-definition `(,(if (string= kind "union")
289				 'UFFI:DEF-UNION
290				 'UFFI:DEF-STRUCT)
291			    ,(make-cl-symbol name) ,@(nreverse *struct-fields*)))))
292
293(defmethod handle-node ((node-type (eql 'top)) &key children &allow-other-keys)
294  (dolist (child children)
295    (apply 'handle-node child)))
296  
297(defmethod handle-node ((node-type (eql 'include)) &key name children &allow-other-keys)
298  (format *uffi-output* ";; INCLUDE ~A~%" name)
299  (dolist (child children)
300    (apply 'handle-node child)))
301
302(defmethod handle-node ((node-type (eql 'extern)) &key name children &allow-other-keys)
303  (format *uffi-output* ";; EXTERN \"C\" ~A~%" name)
304  (let ((*linkage* :c))
305    (dolist (child children)
306      (apply 'handle-node child))))
307
308;;(defun compute-uffi-definitions (swig-interface)
309;;  (let ((*uffi-definitions* '()))
310;;    (handle-node swig-interface)
311;;    *uffi-definitions*))
312
313;; Test instances
314
315;;; Link to SWIG itself
316
317#||
318
319(defparameter *c++-compiler* "g++")
320
321(defun stdc++-library (&key env)
322  (let ((error-output (make-string-output-stream)))
323    (let ((name-output (make-string-output-stream)))
324      (let ((proc (ext:run-program
325		   *c++-compiler*
326		   '("-print-file-name=libstdc++.so")
327		   :env env
328		   :input nil
329		   :output name-output
330		   :error error-output)))
331	(unless proc
332	  (error "Could not run ~A" *c++-compiler*))
333	(unless (zerop (ext:process-exit-code proc))
334	  (system:serve-all-events 0)
335	  (error "~A failed:~%~A" *c++-compiler*
336		 (get-output-stream-string error-output))))
337      (string-right-trim '(#\Newline) (get-output-stream-string name-output)))))
338
339(defvar *swig-interface* nil)
340
341(defvar *swig-uffi-pathname* #p"/tmp/swig-uffi.lisp")
342
343(defun link-swig ()
344  (setq *swig-interface*
345	(run-swig (merge-pathnames "Source/swig.i" *swig-source-directory*)
346		  :directory-search-list
347		  (list (merge-pathnames "Source/" *swig-source-directory*))
348		  :module "swig"
349		  :ignore-errors t
350		  :c++ t))
351  (with-open-file (f *swig-uffi-pathname* :direction :output)
352    (let ((*linkage* :c++)
353	  (*uffi-definitions* '())
354	  (*uffi-output* f)
355	  (*uffi-primitive-type-alist* *uffi-default-primitive-type-alist*))
356      (apply 'handle-node *swig-interface*)))
357  (compile-file *swig-uffi-pathname*)
358  (alien:load-foreign (merge-pathnames "Source/libswig.a"
359				       *swig-source-directory*)
360		      :libraries (list (stdc++-library)))
361  ;; FIXME: UFFI stuffes a "-l" in front of the passed library names
362  ;;  (uffi:load-foreign-library (merge-pathnames "Source/libswig.a"
363  ;;                                              *swig-source-directory*)
364  ;;                             :supporting-libraries
365  ;;                             (list (stdc++-library)))
366  (load (compile-file-pathname *swig-uffi-pathname*)))
367
368||#
369
370;;;; TODO:
371
372;; * How to do type lookups?  Is everything important that SWIG knows
373;;   about the types written out?  What to make of typemaps?
374;;
375;; * Wrapped functions should probably automatically COERCE their
376;;   arguments (as of type DOUBLE-FLOAT), to make the functions more
377;;   flexible?
378;;
379;; * Why are the functions created by FFI interpreted?
380;;
381;; * We can't deal with more complicated structs and C++ classes
382;; directly with the FFI; we have to emit SWIG wrappers that access
383;; those classes.
384;;
385;; * A CLOS layer where structure fields are mapped as slots.  It
386;; looks like we need MOP functions to implement this.
387;;
388;; * Maybe modify SWIG so that key-value hashes are distinguished from
389;; value-value hashes.