git.chise.org Git - chise/xemacs-chise.git.1/blob - lisp/gtk-marshal.el

   1 (defconst name-to-return-type
   2   '(("INT" . "guint")
   3     ("CALLBACK" . "GtkCallback")
   4     ("OBJECT" . "GtkObject *")
   5     ("POINTER" . "void *")
   6     ("STRING" . "gchar *")
   7     ("BOOL" . "gboolean")
   8     ("DOUBLE" . "gdouble")
   9     ("FLOAT" . "gfloat")
  10     ("LIST"  . "void *")
  11     ("NONE" . nil)))
  12
  13 (defvar defined-marshallers nil)
  14
  15 (defun get-marshaller-name (rval args)
  16   (concat "emacs_gtk_marshal_" rval "__"
  17           (mapconcat 'identity (or args '("NONE")) "_")))
  18
  19 (defun define-marshaller (rval &rest args)
  20   (let ((name nil)
  21         (internal-rval (assoc rval  name-to-return-type))
  22         (ctr 0)
  23         (func-proto (format "__%s_fn" rval)))
  24     (if (not internal-rval)
  25         (error "Do not know return type of `%s'" rval))
  26     (setq name (get-marshaller-name rval args))
  27
  28     (if (member name defined-marshallers)
  29         (error "Attempe to define the same marshaller more than once! %s" name))
  30
  31     (set-buffer (get-buffer-create "emacs-marshals.c"))
  32     (goto-char (point-max))
  33
  34     (if (or (member "FLOAT" args) (member "DOUBLE" args))
  35         ;; We need to special case anything with FLOAT in the argument
  36         ;; list or the parameters get screwed up royally.
  37         (progn
  38           (setq func-proto (concat (format "__%s__" rval)
  39                                    (mapconcat 'identity args "_")
  40                                    "_fn"))
  41           (insert "typedef "
  42                   (or (cdr internal-rval) "void")
  43                   " (*"
  44                   func-proto ")("
  45                   (mapconcat (lambda (x)
  46                                (cdr (assoc x name-to-return-type))) args ", ")
  47                   ");\n")))
  48
  49     (insert "\n"
  50             "static void\n"
  51             name " (ffi_actual_function func, GtkArg *args)\n"
  52             "{\n"
  53             (format "  %s rfunc = (%s) func;\n" func-proto func-proto))
  54
  55     (if (string= "LIST" rval) (setq rval "POINTER"))
  56
  57     (if (cdr internal-rval)
  58         ;; It has a return type to worry about
  59         (insert "  " (cdr internal-rval) " *return_val;\n\n"
  60                 (format "  return_val = GTK_RETLOC_%s (args[%d]);\n" rval (length args))
  61                 "  *return_val = ")
  62       (insert "  "))
  63     (insert "(*rfunc) (")
  64     (while args
  65       (if (/= ctr 0)
  66           (insert ", "))
  67       (insert (format "GTK_VALUE_%s (args[%d])" (car args) ctr))
  68       (setq args (cdr args)
  69             ctr (1+ ctr)))
  70     (insert ");\n")
  71     (insert "}\n")))
  72
  73 (save-excursion
  74   (find-file "../../src/emacs-marshals.c")
  75   (erase-buffer)
  76   (setq defined-marshallers nil)
  77
  78   (insert "#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x)\n\n")
  79   (insert "#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x)\n\n")
  80
  81   (let ((todo '(
  82                 ("BOOL" "OBJECT" "INT")
  83                 ("BOOL" "OBJECT" "OBJECT" "OBJECT")
  84                 ("BOOL" "OBJECT" "OBJECT")
  85                 ("BOOL" "OBJECT" "POINTER")
  86                 ("BOOL" "OBJECT" "STRING")
  87                 ("BOOL" "OBJECT")
  88                 ("BOOL" "POINTER" "BOOL")
  89                 ("BOOL" "POINTER")
  90                 ("BOOL")
  91                 ("FLOAT" "OBJECT" "FLOAT")
  92                 ("FLOAT" "OBJECT")
  93                 ("INT" "BOOL")
  94                 ("INT" "OBJECT" "ARRAY")
  95                 ("INT" "OBJECT" "INT" "ARRAY")
  96                 ("INT" "OBJECT" "INT" "INT")
  97                 ("INT" "OBJECT" "INT" "STRING")
  98                 ("INT" "OBJECT" "INT")
  99                 ("INT" "OBJECT" "OBJECT")
 100                 ("INT" "OBJECT" "POINTER" "INT" "INT")
 101                 ("INT" "OBJECT" "POINTER" "INT")
 102                 ("INT" "OBJECT" "POINTER")
 103                 ("INT" "OBJECT" "STRING")
 104                 ("INT" "OBJECT")
 105                 ("INT" "POINTER" "INT")
 106                 ("INT" "POINTER" "STRING" "INT")
 107                 ("INT" "POINTER" "STRING" "STRING")
 108                 ("INT" "POINTER" "STRING")
 109                 ("INT" "POINTER")
 110                 ("INT" "STRING" "STRING" "INT" "ARRAY")
 111                 ("INT" "STRING")
 112                 ("INT")
 113                 ("LIST" "OBJECT")
 114                 ("LIST")
 115                 ("NONE" "BOOL")
 116                 ("NONE" "INT" "INT" "INT" "INT")
 117                 ("NONE" "INT" "INT")
 118                 ("NONE" "INT")
 119                 ("NONE" "OBJECT" "BOOL" "INT")
 120                 ("NONE" "OBJECT" "BOOL")
 121                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "BOOL")
 122                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
 123                 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT")
 124                 ("NONE" "OBJECT" "FLOAT" "FLOAT")
 125                 ("NONE" "OBJECT" "FLOAT")
 126                 ("NONE" "OBJECT" "INT" "BOOL")
 127                 ("NONE" "OBJECT" "INT" "FLOAT" "BOOL")
 128                 ("NONE" "OBJECT" "INT" "FLOAT")
 129                 ("NONE" "OBJECT" "INT" "INT" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY")
 130                 ("NONE" "OBJECT" "INT" "INT" "ARRAY")
 131                 ("NONE" "OBJECT" "INT" "INT" "FLOAT" "FLOAT")
 132                 ("NONE" "OBJECT" "INT" "INT" "INT" "INT")
 133                 ("NONE" "OBJECT" "INT" "INT" "INT")
 134                 ("NONE" "OBJECT" "INT" "INT" "POINTER" "POINTER")
 135                 ("NONE" "OBJECT" "INT" "INT" "POINTER")
 136                 ("NONE" "OBJECT" "INT" "INT" "STRING" "INT" "POINTER" "POINTER")
 137                 ("NONE" "OBJECT" "INT" "INT" "STRING")
 138                 ("NONE" "OBJECT" "INT" "INT")
 139                 ("NONE" "OBJECT" "INT" "OBJECT")
 140                 ("NONE" "OBJECT" "INT" "POINTER")
 141                 ("NONE" "OBJECT" "INT" "STRING")
 142                 ("NONE" "OBJECT" "INT")
 143                 ("NONE" "OBJECT" "LIST" "INT")
 144                 ("NONE" "OBJECT" "LIST")
 145                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT" "INT")
 146                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT")
 147                 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL")
 148                 ("NONE" "OBJECT" "OBJECT" "FLOAT" "INT")
 149                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT" "INT" "INT" "INT" "INT")
 150                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT")
 151                 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT")
 152                 ("NONE" "OBJECT" "OBJECT" "INT" "INT")
 153                 ("NONE" "OBJECT" "OBJECT" "INT")
 154                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "INT")
 155                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT" "INT")
 156                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT")
 157                 ("NONE" "OBJECT" "OBJECT" "OBJECT" "POINTER" "POINTER" "INT" "INT")
 158                 ("NONE" "OBJECT" "OBJECT" "OBJECT")
 159                 ("NONE" "OBJECT" "OBJECT" "POINTER")
 160                 ("NONE" "OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT")
 161                 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING" "INT")
 162                 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING")
 163                 ("NONE" "OBJECT" "OBJECT" "STRING")
 164                 ("NONE" "OBJECT" "OBJECT")
 165                 ("NONE" "OBJECT" "POINTER" "BOOL")
 166                 ("NONE" "OBJECT" "POINTER" "INT" "FLOAT" "FLOAT")
 167                 ("NONE" "OBJECT" "POINTER" "INT" "INT" "INT")
 168                 ("NONE" "OBJECT" "POINTER" "INT" "INT")
 169                 ("NONE" "OBJECT" "POINTER" "INT" "POINTER" "POINTER")
 170                 ("NONE" "OBJECT" "POINTER" "INT" "POINTER")
 171                 ("NONE" "OBJECT" "POINTER" "INT" "STRING" "INT" "POINTER" "POINTER")
 172                 ("NONE" "OBJECT" "POINTER" "INT" "STRING")
 173                 ("NONE" "OBJECT" "POINTER" "INT")
 174                 ("NONE" "OBJECT" "POINTER" "POINTER" "INT" "INT" "INT" "INT" "INT" "INT")
 175                 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER" "STRING" "INT")
 176                 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER")
 177                 ("NONE" "OBJECT" "POINTER" "POINTER")
 178                 ("NONE" "OBJECT" "POINTER" "STRING" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL")
 179                 ("NONE" "OBJECT" "POINTER")
 180                 ("NONE" "OBJECT" "STRING" "BOOL")
 181                 ("NONE" "OBJECT" "STRING" "INT" "INT" "INT")
 182                 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT" "INT")
 183                 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT")
 184                 ("NONE" "OBJECT" "STRING" "STRING")
 185                 ("NONE" "OBJECT" "STRING")
 186                 ("NONE" "OBJECT")
 187                 ("NONE" "POINTER" "INT")
 188                 ("NONE" "POINTER" "INT" "INT")
 189                 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT" "INT" "INT")
 190                 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT")
 191                 ("NONE" "POINTER" "POINTER" "INT" "INT" "INT" "INT")
 192                 ("NONE" "POINTER" "POINTER" "INT" "INT")
 193                 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING" "INT")
 194                 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING")
 195                 ("NONE" "POINTER" "POINTER" "POINTER" "POINTER")
 196                 ("NONE" "POINTER" "POINTER")
 197                 ("NONE" "POINTER" "STRING" "STRING")
 198                 ("NONE" "POINTER" "STRING")
 199                 ("NONE" "POINTER")
 200                 ("NONE")
 201                 ("OBJECT" "BOOL" "BOOL" "INT")
 202                 ("OBJECT" "BOOL" "INT")
 203                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
 204                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
 205                 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT")
 206                 ("OBJECT" "INT" "ARRAY")
 207                 ("OBJECT" "INT" "BOOL" "BOOL")
 208                 ("OBJECT" "INT" "INT" "ARRAY")
 209                 ("OBJECT" "INT" "INT" "BOOL")
 210                 ("OBJECT" "INT" "INT" "STRING")
 211                 ("OBJECT" "INT" "INT")
 212                 ("OBJECT" "INT")
 213                 ("OBJECT" "OBJECT" "FLOAT" "INT")
 214                 ("OBJECT" "OBJECT" "INT")
 215                 ("OBJECT" "OBJECT" "OBJECT")
 216                 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT")
 217                 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT")
 218                 ("OBJECT" "OBJECT" "STRING" "INT" "INT")
 219                 ("OBJECT" "OBJECT" "STRING")
 220                 ("OBJECT" "OBJECT")
 221                 ("OBJECT" "POINTER" "POINTER")
 222                 ("OBJECT" "POINTER" "STRING")
 223                 ("OBJECT" "POINTER")
 224                 ("OBJECT" "STRING" "FLOAT" "FLOAT" "FLOAT" "BOOL")
 225                 ("OBJECT" "STRING" "INT" "STRING" "STRING")
 226                 ("OBJECT" "STRING" "OBJECT")
 227                 ("OBJECT" "STRING" "STRING" "STRING" "ARRAY" "STRING" "STRING")
 228                 ("OBJECT" "STRING" "STRING")
 229                 ("OBJECT" "STRING")
 230                 ("OBJECT")
 231                 ("POINTER" "INT" "INT")
 232                 ("POINTER" "INT")
 233                 ("POINTER" "OBJECT" "INT" "INT")
 234                 ("POINTER" "OBJECT" "INT")
 235                 ("POINTER" "OBJECT" "POINTER" "INT")
 236                 ("POINTER" "OBJECT" "POINTER" "POINTER" "ARRAY" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL")
 237                 ("POINTER" "OBJECT" "POINTER")
 238                 ("POINTER" "OBJECT")
 239                 ("POINTER" "POINTER")
 240                 ("POINTER")
 241                 ("STRING" "INT" "INT" "INT")
 242                 ("STRING" "INT")
 243                 ("STRING" "OBJECT" "BOOL")
 244                 ("STRING" "OBJECT" "FLOAT")
 245                 ("STRING" "OBJECT" "INT" "INT")
 246                 ("STRING" "OBJECT" "INT")
 247                 ("STRING" "OBJECT")
 248                 ("STRING" "POINTER" "STRING")
 249                 ("STRING" "POINTER")
 250                 ("STRING")
 251                 )
 252               )
 253         )
 254     (mapc (lambda (x) (apply 'define-marshaller x)) todo)
 255
 256     (insert "\n\f
 257 #include \"hash.h\"
 258 static c_hashtable marshaller_hashtable;
 259
 260 static void initialize_marshaller_storage (void)
 261 {
 262         if (!marshaller_hashtable)
 263         {
 264                 marshaller_hashtable = make_strings_hashtable (100);
 265 ")
 266
 267     (mapc (lambda (x)
 268             (let ((name (get-marshaller-name (car x) (cdr x))))
 269               (insert (format "\t\tputhash (\"%s\", (void *) %s, marshaller_hashtable);\n" name name))))
 270           todo)
 271     (insert "\t};\n"
 272             "}\n"
 273             "
 274 static void *find_marshaller (const char *func_name)
 275 {
 276         void *fn = NULL;
 277         initialize_marshaller_storage ();
 278
 279         if (gethash (func_name, marshaller_hashtable, (CONST void **)&fn))
 280         {
 281                 return (fn);
 282         }
 283
 284         return (NULL);
 285 }
 286 "))
 287
 288   (save-buffer)
 289   (kill-buffer "emacs-marshals.c"))