defs.lisp

   1
   2 ;; typedef char   gchar;
   3 ;; typedef short  gshort;
   4 ;; typedef long   glong;
   5 ;; typedef int    gint;
   6 ;; typedef gint   gboolean;
   7
   8 ;; typedef unsigned char   guchar;
   9 ;; typedef unsigned short  gushort;
  10 ;; typedef unsigned long   gulong;
  11 ;; typedef unsigned int    guint;
  12
  13 ;; typedef float   gfloat;
  14 ;; typedef double  gdouble;
  15
  16 ;; typedef gulong GType
  17 ;; typedef guint32 GQuark
  18
  19 ;; TO DO 1 - expand enums
  20 ;;       2 - resolve simple types, above
  21
  22 (asdf:oos 'asdf:load-op 'iterate)
  23 (asdf:oos 'asdf:load-op 'alexandria)
  24 (asdf:oos 'asdf:load-op 'cl-fad)
  25
  26 (defpackage :defs
  27   (:use :cl :iterate))
  28
  29 (in-package :defs)
  30
  31 (defparameter *type-resolver-table* (make-hash-table :test 'equal))
  32
  33 (defun add-type (newtype basetype)
  34   (setf (gethash newtype *type-resolver-table*) basetype))
  35
  36 (defun is-pointer (type)
  37   (let ((type-string (string type)))
  38         (char= (char type-string (1- (length type-string))) #\*)))
  39
  40 (defun is-func-pointer (type)
  41   (let* ((type-string (string type))
  42                  (type-string-len (length type-string)))
  43     (or
  44      (and (> type-string-len 4)
  45           (string= "FUNC" (string-upcase (subseq  type-string (- type-string-len 4)))))
  46      (and (> type-string-len (length "Function"))
  47           (string= "FUNCTION" (string-upcase (subseq  type-string (- type-string-len (length "Function")))))))))
  48
  49 (defun resolve-type (type)
  50   (cond
  51     ((null type) :void)
  52     ((or (is-pointer type) (is-func-pointer type))
  53      :pointer)
  54     (t
  55      (let ((result (gethash type *type-resolver-table* nil)))
  56        (unless result
  57          ;; offer restarts?
  58          :pointer)
  59        (unless (symbolp result)
  60          (resolve-type result))
  61        result))))
  62
  63 (add-type "gchar" :char)
  64 (add-type "gshort" :short)
  65 (add-type "glong" :long)
  66 (add-type "gint" :int)
  67 (add-type "guint32" :unsigned-int)
  68 (add-type "gboolean" "gint")
  69 (add-type "guchar" :unsigned-char)
  70 (add-type "gushort" :unsigned-short)
  71 (add-type "gulong" :unsigned-long)
  72 (add-type "guint" :unsigned-int)
  73 (add-type "gfloat" :float)
  74 (add-type "gdouble" :double)
  75 (add-type "gpointer" :pointer)
  76 (add-type "none" :void)
  77 (add-type "GType" "gulong") ;; actually its std::size_t - if it isn't gulong we lose :(
  78 (add-type "GQuark" "guint")
  79 (add-type "GdkDestroyNotify" :pointer)
  80 (add-type "GtkDestroyNotify" :pointer)
  81
  82 ;; enum not declared
  83 (add-type "GdkModifierType" :unsigned-long)
  84
  85 (add-type "GtkAccelMapForeach" :pointer)
  86 (add-type "GCallback" :pointer)
  87 (add-type "GdkAtom" :pointer)
  88
  89 ;; void (*GDestroyNotify) (gpointer data)
  90
  91 ;; Specifies the type of function which is called when a data element
  92 ;; is destroyed. It is passed the pointer to the data element and
  93 ;; should free any memory and resources allocated for it.
  94
  95 (add-type "GDestroyNotify" :pointer)
  96
  97 (defmacro with-gensyms ((&rest names) &body body)
  98   `(let ,(loop for n in names collect `(,n (gensym)))
  99      ,@body))
 100
 101 (defmacro once-only ((&rest names) &body body)
 102   (let ((gensyms (loop for n in names collect (gensym))))
 103     `(let (,@(loop for g in gensyms collect `(,g (gensym))))
 104            `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n)))
 105                   ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g)))
 106                                 ,@body)))))
 107
 108 (defun remove-prefix (prefix string)
 109   (let ((result
 110                  (if (equalp (subseq string 0 (1- (length prefix))) prefix)
 111                          (subseq string 0 (1- (length prefix)))
 112                          string)))
 113         (if (member (char result 0) '( #\_ #\-))
 114                 (subseq result 1)
 115                 result)))
 116
 117 (defun dequote (l)
 118   "If the first element of a list is a quote, strip it away"
 119   (when (list l)
 120     (if (eql  (first l) 'quote)
 121         (rest l)
 122         l)))
 123
 124 (defmacro format-with-properties (property-sym &body properties)
 125   (mapcar
 126    #'(lambda (x)
 127            `(format t ,(cadr x)
 128                                 (remove-prefix ,(getf property-sym 'in-module) ,(getf property-sym (car x)))))
 129    properties))
 130
 131 ;; defs
 132
 133 (defparameter *def-table* (make-hash-table :test 'equal))
 134
 135 (defun add-def-type (def-name def-fn)
 136   (setf (gethash def-name *def-table*) def-fn))
 137
 138 (defun call-def-fn (def-name form)
 139   (let ((exec-fn (gethash def-name *def-table*)))
 140     (when exec-fn
 141       (funcall exec-fn form))))
 142
 143 (defparameter *read-and-discard* nil)
 144 (defparameter *top-level-defs-file* nil)
 145
 146 (defun read-defs-file (fname)
 147   (progn
 148         (set-dispatch-macro-character #\# #\t
 149                                                                   #'(lambda (s c n)
 150                                                                           (declare (ignore s c n))
 151                                                                           't))
 152         (set-dispatch-macro-character #\# #\f
 153                                                                   #'(lambda (s c n)
 154                                                                           (declare (ignore s c n))
 155                                                                           'nil))
 156         (setf *top-level-defs-file* fname)
 157         (with-open-file (ins fname)
 158       (iterate
 159         (for item in-stream ins)
 160         (call-def-fn (first item) item)))))
 161
 162 ;; include
 163
 164 (defun exec-def-include (&rest form)
 165   (let ((fname
 166          (merge-pathnames (cadar form)
 167                           (directory-namestring *top-level-defs-file*))))
 168     (when (cl-fad::file-exists-p fname)
 169       (format t ";; including ~A ~%" fname)
 170       (read-defs-file fname))))
 171
 172 (add-def-type 'INCLUDE 'exec-def-include)
 173
 174 (defun destructure-def-form (form)
 175   (let*
 176       ((real-form (car form))
 177        (name (cadr real-form))
 178        (info (cddr real-form))
 179        (result (make-hash-table :test 'eql)))
 180     (setf (gethash 'NAME result) name)
 181     (format t "Name is ~A~%" name)
 182     (format t "Destructuring ~A~%" info)
 183     (iterate
 184       (for item in  info)
 185       (format t "processing item  ~A~%" item)
 186       (setf (gethash (car  item) result) (cdr item)))
 187     result))
 188
 189 ;; enum
 190 (defun exec-def-enum (&rest form)
 191   (let ((properties (destructure-def-form form)))
 192     (format t ";; enum ~A (~A) " (gethash 'NAME properties) (gethash 'C-NAME properties))
 193     (when (gethash 'C-NAME properties)
 194       (add-type (gethash 'C-NAME properties) :unsigned-long))))
 195
 196 (add-def-type 'DEFINE-ENUM 'exec-def-enum)
 197
 198 ;;                ,(mapcar #'(lambda (x) `(format *debug-io* "Param : ~S~%" ,(car x))) params)))
 199
 200
 201 ;;   (with-gensyms (boxed-props)
 202 ;;      (setf (symbol-plist ,boxed-props) ',@params)
 203 ;;      (format-with-properties
 204 ;;       ,boxed-props
 205 ;;       (gtype-id "(defconstant +~A+~%")
 206 ;;       (copy-func "(cffi:defcfun ~A :pointer (:pointer fresh-copy))")
 207 ;;       (free-func "(cffi:defcfun ~A :void (:pointer this))")))))
 208
 209
 210 ;; flags
 211
 212 ;; (defmacro define-flags (name &rest params)
 213 ;;   `(with-gtk-def gtk-def
 214 ;;       ("flags" ',name ,params)
 215 ;;      (let* ((gtk-params (cddddr gtk-def))
 216 ;;             (flag-values (find-if #'(lambda (x) (equalp (cadr x) "VALUES"))
 217 ;;                                   (cdr gtk-params)))
 218 ;;             (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
 219 ;;                              (cdr gtk-params))))
 220 ;;        ;; to do -- define a bunch of constants for each flag value
 221 ;;        (add-type (cadddr c-name) :unsigned-long))))
 222
 223 (defun exec-def-flags (&rest form)
 224   (let ((properties (destructure-def-form form)))
 225     (format t ";; flags ~A (~A) " (gethash 'NAME properties) (gethash 'C-NAME properties))
 226     (when (gethash 'C-NAME properties)
 227       (add-type (gethash 'C-NAME properties) :unsigned-long))))
 228
 229 (add-def-type 'DEFINE-FLAGS 'exec-def-flags)
 230
 231 ;; probably the silliest name ..
 232 (defmacro def-def-exec  ((name params) &body forms)
 233   `(add-def-type ',name
 234                  (lambda (&rest ,params)
 235                    ,@forms)))
 236
 237 (def-def-exec (DEFINE-OBJECT params)
 238   (let ((properties (destructure-def-form params)))
 239     (format t ";; object ~A ~A " (gethash 'NAME properties)
 240             (gethash 'C-NAME properties))))
 241
 242 (def-def-exec (DEFINE-INTERFACE params)
 243   (let ((properties (destructure-def-form params)))
 244     (format t ";; interface ~A ~A " (gethash 'NAME properties)
 245             (gethash 'C-NAME properties))))
 246
 247 (def-def-exec (DEFINE-BOXED params)
 248   (let ((properties (destructure-def-form params)))
 249     (format t ";; boxed ~A ~A " (gethash 'NAME properties)
 250             (gethash 'C-NAME properties))))
 251
 252 (def-def-exec (DEFINE-VIRTUAL params)
 253   (let ((properties (destructure-def-form params)))
 254     (format t ";; virtual ~A ~A " (gethash 'NAME properties)
 255             (gethash 'C-NAME properties))))
 256
 257 (def-def-exec (DEFINE-TYPE params)
 258   (let ((properties (destructure-def-form params)))
 259     (format t ";; type ~A ~A " (gethash 'NAME properties)
 260             (gethash 'C-NAME properties))))
 261
 262 (def-def-exec (DEFINE-STRUCT params)
 263   (let ((properties (destructure-def-form params)))
 264     (format t ";; struct ~A ~A " (gethash 'NAME properties)
 265             (gethash 'C-NAME properties))))
 266
 267 (def-def-exec (DEFINE-TYPEDEF params)
 268   (let ((properties (destructure-def-form params)))
 269     (format t ";; typedef ~A ~A " (gethash 'NAME properties)
 270             (gethash 'C-NAME properties))))
 271
 272
 273 (def-def-exec (DEFINE-POINTER params)
 274   (let ((properties (destructure-def-form params)))
 275     (format t ";; pointer ~A ~A " (gethash 'NAME properties)
 276             (gethash 'C-NAME properties))))
 277
 278 ;;(TYPE function NAME ASSISTANT_NEW PARAMS (PARAM C-NAME VALUE gtk_assistant_new) (PARAM IS-CONSTRUCTOR-OF VALUE GtkAssistant) (PARAM RETURN-TYPE VALUE GtkWidget*))
 279
 280 ;;(TYPE function NAME LINK_BUTTON_GET_TYPE PARAMS (PARAM C-NAME VALUE gtk_link_button_get_type) (PARAM RETURN-TYPE VALUE GType))
 281
 282 ;;(TYPE function NAME PAPER_SIZE_NEW_FROM_PPD PARAMS (PARAM C-NAME VALUE gtk_paper_size_new_from_ppd) (PARAM RETURN-TYPE VALUE GtkPaperSize*) (PARAM PARAMETERS VALUE (const-gchar* ppd_name) (const-gchar* ppd_display_name) (gdouble width) (gdouble height)))
 283
 284 ;; (defmacro define-function (name &rest params)
 285 ;;   `(with-gtk-def gtk-def ("function" ',name ,params)
 286 ;;       (let* ((gtk-params (cddddr gtk-def))
 287 ;;                      (return-type (find-if #'(lambda (x) (equalp (cadr x) "RETURN-TYPE"))
 288 ;;                                                       (cdr gtk-params)))
 289 ;;                      (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
 290 ;;                                                       (cdr gtk-params)))
 291 ;;                      (fn-parameters (find-if #'(lambda (x) (equalp (cadr x) "PARAMETERS"))
 292 ;;                                                       (cdr gtk-params))))
 293 ;;         (format *debug-io* "~%~%(defcfun ~A ~A" (cadddr c-name) (resolve-type (cadddr return-type)))
 294 ;;         (when fn-parameters
 295 ;;               (loop
 296 ;;                      for fn-parameter in (cdddr fn-parameters)
 297 ;;                      do (format *debug-io* "~&~T( ~A ~A )" (cadr fn-parameter) (resolve-type (car fn-parameter)))))
 298 ;;         (format *debug-io* ")~%"))))
 299
 300
 301 (def-def-exec (DEFINE-FUNCTION params)
 302   (let ((properties (destructure-def-form params)))
 303     (format t ";; function ~A ~A " (gethash 'NAME properties)
 304             (gethash 'C-NAME properties))))
 305
 306
 307 ;; (defmacro define-method (name &rest params)
 308 ;;   `(with-gtk-def gtk-def ("method" ',name ,params)
 309 ;;       (let* ((gtk-params (cddddr gtk-def))
 310 ;;                      (of-object (find-if #'(lambda (x) (equalp (cadr x) "OF-OBJECT"))
 311 ;;                                                       (cdr gtk-params)))
 312 ;;                      (return-type (find-if #'(lambda (x) (equalp (cadr x) "RETURN-TYPE"))
 313 ;;                                                       (cdr gtk-params)))
 314 ;;                      (c-name (find-if #'(lambda (x) (equalp (cadr x) "C-NAME"))
 315 ;;                                                       (cdr gtk-params)))
 316 ;;                      (fn-parameters (find-if #'(lambda (x) (equalp (cadr x) "PARAMETERS"))
 317 ;;                                                       (cdr gtk-params))))
 318 ;;         (format *debug-io* "~%~%(defcfun ~A ~A" (cadddr c-name) (resolve-type (cadddr return-type)))
 319 ;;         ;; to do -- transforn name from "GtkAccelGroup" style to "gtk-accel-group"
 320 ;;         (format *debug-io* "~&~T(~A ~S)" (cadddr of-object) :pointer)
 321 ;;         (when fn-parameters
 322 ;;               (loop
 323 ;;                      for fn-parameter in (cdddr fn-parameters)
 324 ;;                      do (format *debug-io* "~&~T( ~A ~A )" (cadr fn-parameter) (resolve-type  (car fn-parameter)))))
 325 ;;         (format *debug-io* ")~%"))))
 326
 327 (def-def-exec (DEFINE-METHOD params)
 328   (let ((properties (destructure-def-form params)))
 329     (format t ";; method ~A ~A " (gethash 'NAME properties)
 330             (gethash 'C-NAME properties))))
 331
 332 (defparameter HAVE_GTK_2_12 t)
 333
 334 (def-def-exec (DEFINE-IFDEF params)
 335   (destructuring-bind ((name symb &rest forms)) params
 336     (when (ignore-errors (symbol-value (find-symbol (string symb))))
 337       (iterate
 338         (for form in forms)
 339         (call-def-fn (first form) form)))))
 340
 341 (def-def-exec (DEFINE-IFNDEF params)
 342   (destructuring-bind ((name symb &rest forms)) params
 343     (unless (ignore-errors (symbol-value (find-symbol (string symb))))
 344       (iterate
 345         (for form in forms)
 346         (call-def-fn (first form) form))))
 347
 348
 349
 350 (def-def-exec (DEFINE-PROPERTY params)
 351   (let ((properties (destructure-def-form params)))
 352     (format t ";; property ~A ~A " (gethash 'NAME properties)
 353             (gethash 'C-NAME properties))))
 354
 355 ;; (defmacro define-property (name &rest params)
 356 ;;   `(with-gtk-def gtk-def ( "property" ',name ,params )
 357 ;;                               (format *debug-io* "~A" gtk-def)))
 358
 359 (def-def-exec (DEFINE-SIGNAL params)
 360   (let ((properties (destructure-def-form params)))
 361     (format t ";; signal ~A ~A " (gethash 'NAME properties)
 362             (gethash 'C-NAME properties))))
 363
 364 ;; (defmacro define-signal (name &rest params)
 365 ;;   `(with-gtk-def gtk-def ( "signal" ',name ,params )
 366 ;;                               (format *debug-io* "~A" gtk-def)))
 367
 368
 369
 370
 371
 372 (read-defs-file "/usr/share/pygtk/2.0/defs/gtk.defs")
 373
 374 ;; (define-boxed PaperSize
 375 ;;   (in-module "Gtk")
 376 ;;   (c-name "GtkPaperSize")
 377 ;;   (gtype-id "GTK_TYPE_PAPER_SIZE")
 378 ;; )
 379