gir-loader.lisp

   1 ;; Copyright (c) 2008 John Connors (johnc@yagc.ndo.remove.this.please.co.uk).
   2 ;;
   3 ;; Permission is hereby granted, free of charge, to any person obtaining a
   4 ;; copy of this software and associated documentation files (the "Software"), to
   5 ;; deal in the Software without restriction, including without limitation the
   6 ;; rights to use, copy, modify, merge, publish, distribute, sublicense, and/or
   7 ;; sell copies of the Software, and to permit persons to whom the Software is
   8 ;; furnished to do so, subject to the following conditions:
   9 ;;
  10 ;; The above copyright notice and this permission notice shall be included in all
  11 ;; copies or substantial portions of the Software.
  12 ;;
  13 ;; THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
  14 ;; IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
  15 ;; FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
  16 ;; AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
  17 ;; LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
  18 ;; OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
  19 ;; SOFTWARE.
  20
  21 (asdf:oos 'asdf:load-op 'iterate)
  22 (asdf:oos 'asdf:load-op 'cffi)
  23 (asdf:oos 'asdf:load-op 'cl-ppcre)
  24 (asdf:oos 'asdf:load-op 's-xml)
  25 (asdf:oos 'asdf:load-op 'alexandria)
  26
  27 (defpackage :gir
  28   (:use :common-lisp :s-xml :iterate))
  29
  30 (in-package :gir)
  31
  32 (defun lispize (fn-name)
  33   "Turn a c-gtk name into a lisp one"
  34   (intern (string-upcase (substitute #\- #\_
  35                                       fn-name))))
  36
  37 (defparameter *type-resolver-table* (make-hash-table :test 'equal))
  38
  39 (defun add-type (newtype basetype)
  40   (setf (gethash newtype *type-resolver-table*) basetype))
  41
  42 (defun is-pointer (type)
  43   (let ((type-string (string type)))
  44         (char= (char type-string (1- (length type-string))) #\*)))
  45
  46 ;; (defun is-func-pointer (type)
  47 ;;   (let* ((type-string (string type))
  48 ;;               (type-string-len (length type-string)))
  49 ;;     (or
  50 ;;      (and (> type-string-len 4)
  51 ;;           (string= "FUNC" (string-upcase (subseq  type-string (- type-string-len 4)))))
  52 ;;      (and (> type-string-len (length "Function"))
  53 ;;           (string= "FUNCTION" (string-upcase (subseq  type-string (- type-string-len (length "Function")))))))))
  54
  55 (defun resolve-type (type)
  56   (cond
  57     ((null type) :void)
  58     ((is-pointer type) :pointer)
  59     (t
  60      (let ((result (gethash type *type-resolver-table* nil)))
  61        (unless (or (null result) (symbolp result))
  62          (resolve-type result))
  63        (if result
  64            result
  65            type)))))
  66
  67 ;; instead of this, why not use defctype?
  68
  69 (add-type "gchar" :char)
  70 (add-type "gshort" :short)
  71 (add-type "guint16" :unsigned-short)
  72 (add-type "glong" :long)
  73 (add-type "gint" :int)
  74 (add-type "guint32" :unsigned-int)
  75 (add-type "gboolean" "gint")
  76 (add-type "guchar" :unsigned-char)
  77 (add-type "gushort" :unsigned-short)
  78 (add-type "gulong" :unsigned-long)
  79 (add-type "guint" :unsigned-int)
  80 (add-type "gfloat" :float)
  81 (add-type "gdouble" :double)
  82 (add-type "gpointer" :pointer)
  83 (add-type "none" :void)
  84 (add-type "GType" "gulong") ;; actually its std::size_t - if it isn't gulong we lose :(
  85 (add-type "GQuark" "guint")
  86
  87 (defun parse-gir (gir-in)
  88   (s-xml:parse-xml gir-in :output-type :xml-struct))
  89
  90 (defun parse-gir-file (pathname)
  91   (with-open-file (gir-in pathname)
  92     (parse-gir gir-in)))
  93
  94 (s-xml:register-namespace "http://www.gtk.org/introspection/core/1.0" "" '|gir| )
  95 (s-xml:register-namespace "http://www.gtk.org/introspection/c/1.0" "c" '|c|)
  96 (s-xml:register-namespace "http://www.gtk.org/introspection/glib/1.0" "c" '|glib|)
  97
  98 (defparameter *gir-xml* (parse-gir-file #P"/home/johnc/projects/trivial-gtk/gir-repository/gir/gdk-x11-2.0.gir"))
  99