Examples/s-exp/uffi.lisp

   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++
  46 types. Return two values: The type description (an improper list) and
  47 the 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
 143 value is the list of argument types, and the third value is the return
 144 type."
 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
 179 is 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 #||
 316
 317 #+ignore
 318 (defvar *gifplot-interface*
 319   (run-swig (merge-pathnames "Examples/GIFPlot/Interface/gifplot.i"
 320                              *swig-source-directory*)
 321             :directory-search-list (list (merge-pathnames "Examples/GIFPlot/Interface/" *swig-source-directory*))))
 322
 323 (defvar *simple-gifplot-interface*
 324   (run-swig (merge-pathnames "Examples/GIFPlot/Include/gifplot.h"
 325                              *swig-source-directory*)
 326             :directory-search-list (list (merge-pathnames "Examples/GIFPlot/Interface/" *swig-source-directory*))
 327             :module "gifplot"))
 328
 329 (defvar *cplex-glue-directory* #p"/home/mkoeppe/cvs/cplex-glue/")
 330
 331 (defvar *cplex-glue-interface*
 332   (run-swig (merge-pathnames "cplex.i" *cplex-glue-directory*)
 333             :directory-search-list (list (merge-pathnames "Lib/guile"
 334                                                           *swig-source-directory*)
 335                                          *cplex-glue-directory*)
 336             :ignore-errors t))
 337
 338
 339
 340 (require 'uffi)
 341
 342 ;;(let ((*uffi-primitive-type-alist* (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
 343 ;;  (eval (cons 'progn (compute-uffi-definitions *simple-gifplot-interface*))))
 344
 345
 346 (with-open-file (f "/tmp/swig-uffi.lisp" :direction :output
 347                    :if-exists :supersede)
 348   (let ((*uffi-definitions* '())
 349         (*uffi-output* f)
 350         (*uffi-primitive-type-alist*
 351          (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
 352     (apply 'handle-node *simple-gifplot-interface*)))
 353
 354 #+cplex
 355 (with-open-file (f "/tmp/swig-uffi.lisp" :direction :output)
 356   (let ((*uffi-definitions* '())
 357         (*uffi-output* f)
 358         (*uffi-primitive-type-alist*
 359          (cons '("Pixel" . :unsigned-int) *uffi-default-primitive-type-alist*)))
 360     (apply 'handle-node *cplex-glue-interface*)))
 361
 362 (compile-file "/tmp/swig-uffi.lisp")
 363
 364 (uffi:load-foreign-library (merge-pathnames "Examples/GIFPlot/libgifplot.a"
 365                                             *swig-source-directory*))
 366
 367 (load "/tmp/swig-uffi.lisp")
 368
 369 (load (merge-pathnames "Examples/GIFPlot/Common-Lisp/full/runme.lisp" *swig-source-directory*))
 370
 371 (action (namestring (merge-pathnames "Examples/GIFPlot/Common-Lisp/full/cmap"
 372                                      *swig-source-directory*)))
 373
 374 ||#
 375
 376 ;;; Link to SWIG itself
 377
 378 #||
 379
 380 (defparameter *c++-compiler* "g++")
 381
 382 (defun stdc++-library (&key env)
 383   (let ((error-output (make-string-output-stream)))
 384     (let ((name-output (make-string-output-stream)))
 385       (let ((proc (ext:run-program
 386                    *c++-compiler*
 387                    '("-print-file-name=libstdc++.so")
 388                    :env env
 389                    :input nil
 390                    :output name-output
 391                    :error error-output)))
 392         (unless proc
 393           (error "Could not run ~A" *c++-compiler*))
 394         (unless (zerop (ext:process-exit-code proc))
 395           (system:serve-all-events 0)
 396           (error "~A failed:~%~A" *c++-compiler*
 397                  (get-output-stream-string error-output))))
 398       (string-right-trim '(#\Newline) (get-output-stream-string name-output)))))
 399
 400 (defvar *swig-interface* nil)
 401
 402 (defvar *swig-uffi-pathname* #p"/tmp/swig-uffi.lisp")
 403
 404 (defun link-swig ()
 405   (setq *swig-interface*
 406         (run-swig (merge-pathnames "Source/swig.i" *swig-source-directory*)
 407                   :directory-search-list
 408                   (list (merge-pathnames "Source/" *swig-source-directory*))
 409                   :module "swig"
 410                   :ignore-errors t
 411                   :c++ t))
 412   (with-open-file (f *swig-uffi-pathname* :direction :output)
 413     (let ((*linkage* :c++)
 414           (*uffi-definitions* '())
 415           (*uffi-output* f)
 416           (*uffi-primitive-type-alist* *uffi-default-primitive-type-alist*))
 417       (apply 'handle-node *swig-interface*)))
 418   (compile-file *swig-uffi-pathname*)
 419   (alien:load-foreign (merge-pathnames "Source/libswig.a"
 420                                        *swig-source-directory*)
 421                       :libraries (list (stdc++-library)))
 422   ;; FIXME: UFFI stuffes a "-l" in front of the passed library names
 423   ;;  (uffi:load-foreign-library (merge-pathnames "Source/libswig.a"
 424   ;;                                              *swig-source-directory*)
 425   ;;                             :supporting-libraries
 426   ;;                             (list (stdc++-library)))
 427   (load (compile-file-pathname *swig-uffi-pathname*)))
 428
 429 ||#
 430
 431 ;;;; TODO:
 432
 433 ;; * How to do type lookups?  Is everything important that SWIG knows
 434 ;;   about the types written out?  What to make of typemaps?
 435 ;;
 436 ;; * Wrapped functions should probably automatically COERCE their
 437 ;;   arguments (as of type DOUBLE-FLOAT), to make the functions more
 438 ;;   flexible?
 439 ;;
 440 ;; * Why are the functions created by FFI interpreted?
 441 ;;
 442 ;; * We can't deal with more complicated structs and C++ classes
 443 ;; directly with the FFI; we have to emit SWIG wrappers that access
 444 ;; those classes.
 445 ;;
 446 ;; * A CLOS layer where structure fields are mapped as slots.  It
 447 ;; looks like we need MOP functions to implement this.
 448 ;;
 449 ;; * Maybe modify SWIG so that key-value hashes are distinguished from
 450 ;; value-value hashes.