Mercurial > hg > xemacs-beta
annotate lisp/gtk-marshal.el @ 5265:5663ae9a8989
Warn at compile time, error at runtime, with (quote X Y), (function X Y).
lisp/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* bytecomp.el (byte-compile-function-form, byte-compile-quote)
(byte-compile-quote-form):
Warn at compile time, and error at runtime, if a (quote ...) or a
(function ...) form attempts to quote more than one object.
src/ChangeLog addition:
2010-09-16 Aidan Kehoe <kehoea@parhasard.net>
* eval.c (Ffunction, Fquote):
Add argument information in the arguments: () format for these two
special operators.
| author | Aidan Kehoe <kehoea@parhasard.net> |
|---|---|
| date | Thu, 16 Sep 2010 14:10:44 +0100 |
| parents | ba07c880114a |
| children | cd167465bf69 91b3aa59f49b |
| rev | line source |
|---|---|
|
4709
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
1 ;; This file is part of XEmacs. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
2 ;; |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
3 ;; XEmacs is free software; you can redistribute it and/or modify it |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
4 ;; under the terms of the GNU General Public License as published by the |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
5 ;; Free Software Foundation; either version 2, or (at your option) any |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
6 ;; later version. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
7 ;; |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
8 ;; XEmacs is distributed in the hope that it will be useful, but WITHOUT |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
9 ;; ANY WARRANTY; without even the implied warranty of MERCHANTABILITY or |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
10 ;; FITNESS FOR A PARTICULAR PURPOSE. See the GNU General Public License |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
11 ;; for more details. |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
12 ;; |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
13 ;; You should have received a copy of the GNU General Public License |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
14 ;; along with XEmacs; see the file COPYING. If not, write to |
|
db7068430402
Add explicit GPL v2 or later notices to Bill Perry's code, where such notices
Jerry James <james@xemacs.org>
parents:
2523
diff
changeset
|
15 ;; the Free Software Foundation, Inc., 51 Franklin Street - Fifth Floor, |
|
5231
ba07c880114a
Fix up FSF's Franklin Street address in many files.
Stephen J. Turnbull <stephen@xemacs.org>
parents:
4709
diff
changeset
|
16 ;; Boston, MA 02110-1301, USA. */ |
| 2054 | 17 ;; |
| 18 ;; To regenerate ../src/emacs-marshals.c just load this file. | |
| 19 ;; | |
| 462 | 20 (defconst name-to-return-type |
| 2054 | 21 '(("INT" . "gint") |
| 462 | 22 ("CALLBACK" . "GtkCallback") |
| 23 ("OBJECT" . "GtkObject *") | |
| 24 ("POINTER" . "void *") | |
| 25 ("STRING" . "gchar *") | |
| 26 ("BOOL" . "gboolean") | |
| 27 ("DOUBLE" . "gdouble") | |
| 28 ("FLOAT" . "gfloat") | |
| 29 ("LIST" . "void *") | |
| 30 ("NONE" . nil))) | |
| 31 | |
| 32 (defvar defined-marshallers nil) | |
| 33 | |
| 34 (defun get-marshaller-name (rval args) | |
| 35 (concat "emacs_gtk_marshal_" rval "__" | |
| 36 (mapconcat 'identity (or args '("NONE")) "_"))) | |
| 37 | |
| 38 (defun define-marshaller (rval &rest args) | |
| 39 (let ((name nil) | |
| 40 (internal-rval (assoc rval name-to-return-type)) | |
| 41 (ctr 0) | |
| 42 (func-proto (format "__%s_fn" rval))) | |
| 43 (if (not internal-rval) | |
| 44 (error "Do not know return type of `%s'" rval)) | |
| 45 (setq name (get-marshaller-name rval args)) | |
| 46 | |
| 47 (if (member name defined-marshallers) | |
| 2054 | 48 (error "Attempt to define the same marshaller more than once! %s" name)) |
| 462 | 49 |
| 50 (set-buffer (get-buffer-create "emacs-marshals.c")) | |
| 51 (goto-char (point-max)) | |
| 52 | |
| 53 (if (or (member "FLOAT" args) (member "DOUBLE" args)) | |
| 54 ;; We need to special case anything with FLOAT in the argument | |
| 55 ;; list or the parameters get screwed up royally. | |
| 56 (progn | |
| 57 (setq func-proto (concat (format "__%s__" rval) | |
| 58 (mapconcat 'identity args "_") | |
| 59 "_fn")) | |
| 60 (insert "typedef " | |
| 61 (or (cdr internal-rval) "void") | |
| 62 " (*" | |
| 63 func-proto ")(" | |
| 64 (mapconcat (lambda (x) | |
| 65 (cdr (assoc x name-to-return-type))) args ", ") | |
| 66 ");\n"))) | |
| 67 | |
| 68 (insert "\n" | |
| 69 "static void\n" | |
| 70 name " (ffi_actual_function func, GtkArg *args)\n" | |
| 71 "{\n" | |
| 72 (format " %s rfunc = (%s) func;\n" func-proto func-proto)) | |
| 73 | |
| 74 (if (string= "LIST" rval) (setq rval "POINTER")) | |
| 75 | |
| 76 (if (cdr internal-rval) | |
| 77 ;; It has a return type to worry about | |
| 78 (insert " " (cdr internal-rval) " *return_val;\n\n" | |
| 79 (format " return_val = GTK_RETLOC_%s (args[%d]);\n" rval (length args)) | |
| 80 " *return_val = ") | |
| 81 (insert " ")) | |
| 82 (insert "(*rfunc) (") | |
| 83 (while args | |
| 84 (if (/= ctr 0) | |
| 85 (insert ", ")) | |
| 86 (insert (format "GTK_VALUE_%s (args[%d])" (car args) ctr)) | |
| 87 (setq args (cdr args) | |
| 88 ctr (1+ ctr))) | |
| 89 (insert ");\n") | |
| 90 (insert "}\n"))) | |
| 91 | |
| 92 (save-excursion | |
| 591 | 93 (find-file "../src/emacs-marshals.c") |
| 462 | 94 (erase-buffer) |
| 95 (setq defined-marshallers nil) | |
| 96 | |
| 591 | 97 (insert "/* This file was automatically generated by ../lisp/gtk-marshal.el */\n" |
| 98 "/* DO NOT EDIT BY HAND!!! */\n") | |
| 462 | 99 (insert "#define GTK_VALUE_ARRAY(x) GTK_VALUE_POINTER(x)\n\n") |
| 100 (insert "#define GTK_VALUE_LIST(x) GTK_VALUE_POINTER(x)\n\n") | |
| 101 | |
| 102 (let ((todo '( | |
| 103 ("BOOL" "OBJECT" "INT") | |
| 104 ("BOOL" "OBJECT" "OBJECT" "OBJECT") | |
| 105 ("BOOL" "OBJECT" "OBJECT") | |
| 106 ("BOOL" "OBJECT" "POINTER") | |
| 107 ("BOOL" "OBJECT" "STRING") | |
| 108 ("BOOL" "OBJECT") | |
| 109 ("BOOL" "POINTER" "BOOL") | |
| 110 ("BOOL" "POINTER") | |
| 111 ("BOOL") | |
| 112 ("FLOAT" "OBJECT" "FLOAT") | |
| 113 ("FLOAT" "OBJECT") | |
| 114 ("INT" "BOOL") | |
| 115 ("INT" "OBJECT" "ARRAY") | |
| 116 ("INT" "OBJECT" "INT" "ARRAY") | |
| 117 ("INT" "OBJECT" "INT" "INT") | |
| 118 ("INT" "OBJECT" "INT" "STRING") | |
| 119 ("INT" "OBJECT" "INT") | |
| 120 ("INT" "OBJECT" "OBJECT") | |
| 121 ("INT" "OBJECT" "POINTER" "INT" "INT") | |
| 122 ("INT" "OBJECT" "POINTER" "INT") | |
| 123 ("INT" "OBJECT" "POINTER") | |
| 124 ("INT" "OBJECT" "STRING") | |
| 125 ("INT" "OBJECT") | |
| 126 ("INT" "POINTER" "INT") | |
| 127 ("INT" "POINTER" "STRING" "INT") | |
| 128 ("INT" "POINTER" "STRING" "STRING") | |
| 129 ("INT" "POINTER" "STRING") | |
| 130 ("INT" "POINTER") | |
| 131 ("INT" "STRING" "STRING" "INT" "ARRAY") | |
| 132 ("INT" "STRING") | |
| 133 ("INT") | |
| 134 ("LIST" "OBJECT") | |
| 135 ("LIST") | |
| 136 ("NONE" "BOOL") | |
| 137 ("NONE" "INT" "INT" "INT" "INT") | |
| 138 ("NONE" "INT" "INT") | |
| 139 ("NONE" "INT") | |
| 140 ("NONE" "OBJECT" "BOOL" "INT") | |
| 141 ("NONE" "OBJECT" "BOOL") | |
| 142 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "BOOL") | |
| 143 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") | |
| 144 ("NONE" "OBJECT" "FLOAT" "FLOAT" "FLOAT") | |
| 145 ("NONE" "OBJECT" "FLOAT" "FLOAT") | |
| 146 ("NONE" "OBJECT" "FLOAT") | |
| 147 ("NONE" "OBJECT" "INT" "BOOL") | |
| 148 ("NONE" "OBJECT" "INT" "FLOAT" "BOOL") | |
| 149 ("NONE" "OBJECT" "INT" "FLOAT") | |
| 150 ("NONE" "OBJECT" "INT" "INT" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY" "ARRAY") | |
| 151 ("NONE" "OBJECT" "INT" "INT" "ARRAY") | |
| 152 ("NONE" "OBJECT" "INT" "INT" "FLOAT" "FLOAT") | |
| 153 ("NONE" "OBJECT" "INT" "INT" "INT" "INT") | |
| 154 ("NONE" "OBJECT" "INT" "INT" "INT") | |
| 155 ("NONE" "OBJECT" "INT" "INT" "POINTER" "POINTER") | |
| 156 ("NONE" "OBJECT" "INT" "INT" "POINTER") | |
| 157 ("NONE" "OBJECT" "INT" "INT" "STRING" "INT" "POINTER" "POINTER") | |
| 158 ("NONE" "OBJECT" "INT" "INT" "STRING") | |
| 159 ("NONE" "OBJECT" "INT" "INT") | |
| 160 ("NONE" "OBJECT" "INT" "OBJECT") | |
| 161 ("NONE" "OBJECT" "INT" "POINTER") | |
| 162 ("NONE" "OBJECT" "INT" "STRING") | |
| 163 ("NONE" "OBJECT" "INT") | |
| 164 ("NONE" "OBJECT" "LIST" "INT") | |
| 165 ("NONE" "OBJECT" "LIST") | |
| 166 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT" "INT") | |
| 167 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL" "INT") | |
| 168 ("NONE" "OBJECT" "OBJECT" "BOOL" "BOOL") | |
| 169 ("NONE" "OBJECT" "OBJECT" "FLOAT" "INT") | |
| 170 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT" "INT" "INT" "INT" "INT") | |
| 171 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT" "INT") | |
| 172 ("NONE" "OBJECT" "OBJECT" "INT" "INT" "INT") | |
| 173 ("NONE" "OBJECT" "OBJECT" "INT" "INT") | |
| 174 ("NONE" "OBJECT" "OBJECT" "INT") | |
| 175 ("NONE" "OBJECT" "OBJECT" "OBJECT" "INT") | |
| 176 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT" "INT") | |
| 177 ("NONE" "OBJECT" "OBJECT" "OBJECT" "OBJECT") | |
| 178 ("NONE" "OBJECT" "OBJECT" "OBJECT" "POINTER" "POINTER" "INT" "INT") | |
| 179 ("NONE" "OBJECT" "OBJECT" "OBJECT") | |
| 180 ("NONE" "OBJECT" "OBJECT" "POINTER") | |
| 181 ("NONE" "OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") | |
| 182 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING" "INT") | |
| 183 ("NONE" "OBJECT" "OBJECT" "STRING" "STRING") | |
| 184 ("NONE" "OBJECT" "OBJECT" "STRING") | |
| 185 ("NONE" "OBJECT" "OBJECT") | |
| 186 ("NONE" "OBJECT" "POINTER" "BOOL") | |
| 187 ("NONE" "OBJECT" "POINTER" "INT" "FLOAT" "FLOAT") | |
| 188 ("NONE" "OBJECT" "POINTER" "INT" "INT" "INT") | |
| 189 ("NONE" "OBJECT" "POINTER" "INT" "INT") | |
| 190 ("NONE" "OBJECT" "POINTER" "INT" "POINTER" "POINTER") | |
| 191 ("NONE" "OBJECT" "POINTER" "INT" "POINTER") | |
| 192 ("NONE" "OBJECT" "POINTER" "INT" "STRING" "INT" "POINTER" "POINTER") | |
| 193 ("NONE" "OBJECT" "POINTER" "INT" "STRING") | |
| 194 ("NONE" "OBJECT" "POINTER" "INT") | |
| 195 ("NONE" "OBJECT" "POINTER" "POINTER" "INT" "INT" "INT" "INT" "INT" "INT") | |
| 196 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER" "STRING" "INT") | |
| 197 ("NONE" "OBJECT" "POINTER" "POINTER" "POINTER") | |
| 198 ("NONE" "OBJECT" "POINTER" "POINTER") | |
| 199 ("NONE" "OBJECT" "POINTER" "STRING" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") | |
| 200 ("NONE" "OBJECT" "POINTER") | |
| 201 ("NONE" "OBJECT" "STRING" "BOOL") | |
| 202 ("NONE" "OBJECT" "STRING" "INT" "INT" "INT") | |
| 203 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT" "INT") | |
| 204 ("NONE" "OBJECT" "STRING" "POINTER" "INT" "INT") | |
| 205 ("NONE" "OBJECT" "STRING" "STRING") | |
| 206 ("NONE" "OBJECT" "STRING") | |
| 207 ("NONE" "OBJECT") | |
| 833 | 208 ("NONE" "POINTER" "INT" "INT") |
| 462 | 209 ("NONE" "POINTER" "INT") |
| 210 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT" "INT" "INT") | |
| 211 ("NONE" "POINTER" "POINTER" "BOOL" "INT" "INT" "INT" "INT") | |
| 212 ("NONE" "POINTER" "POINTER" "INT" "INT" "INT" "INT") | |
| 213 ("NONE" "POINTER" "POINTER" "INT" "INT") | |
| 214 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING" "INT") | |
| 215 ("NONE" "POINTER" "POINTER" "POINTER" "INT" "INT" "STRING") | |
| 216 ("NONE" "POINTER" "POINTER" "POINTER" "POINTER") | |
| 217 ("NONE" "POINTER" "POINTER") | |
| 218 ("NONE" "POINTER" "STRING" "STRING") | |
| 219 ("NONE" "POINTER" "STRING") | |
| 220 ("NONE" "POINTER") | |
| 221 ("NONE") | |
| 222 ("OBJECT" "BOOL" "BOOL" "INT") | |
| 223 ("OBJECT" "BOOL" "INT") | |
| 224 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") | |
| 225 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") | |
| 226 ("OBJECT" "FLOAT" "FLOAT" "FLOAT" "FLOAT") | |
| 227 ("OBJECT" "INT" "ARRAY") | |
| 228 ("OBJECT" "INT" "BOOL" "BOOL") | |
| 229 ("OBJECT" "INT" "INT" "ARRAY") | |
| 230 ("OBJECT" "INT" "INT" "BOOL") | |
| 231 ("OBJECT" "INT" "INT" "STRING") | |
| 232 ("OBJECT" "INT" "INT") | |
| 233 ("OBJECT" "INT") | |
| 234 ("OBJECT" "OBJECT" "FLOAT" "INT") | |
| 235 ("OBJECT" "OBJECT" "INT") | |
| 236 ("OBJECT" "OBJECT" "OBJECT") | |
| 237 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT" "INT") | |
| 238 ("OBJECT" "OBJECT" "STRING" "INT" "INT" "INT" "INT") | |
| 239 ("OBJECT" "OBJECT" "STRING" "INT" "INT") | |
| 240 ("OBJECT" "OBJECT" "STRING") | |
| 241 ("OBJECT" "OBJECT") | |
| 242 ("OBJECT" "POINTER" "POINTER") | |
| 243 ("OBJECT" "POINTER" "STRING") | |
| 244 ("OBJECT" "POINTER") | |
| 245 ("OBJECT" "STRING" "FLOAT" "FLOAT" "FLOAT" "BOOL") | |
| 246 ("OBJECT" "STRING" "INT" "STRING" "STRING") | |
| 247 ("OBJECT" "STRING" "OBJECT") | |
| 248 ("OBJECT" "STRING" "STRING" "STRING" "ARRAY" "STRING" "STRING") | |
| 249 ("OBJECT" "STRING" "STRING") | |
| 250 ("OBJECT" "STRING") | |
| 251 ("OBJECT") | |
| 252 ("POINTER" "INT" "INT") | |
| 253 ("POINTER" "INT") | |
| 254 ("POINTER" "OBJECT" "INT" "INT") | |
| 255 ("POINTER" "OBJECT" "INT") | |
| 256 ("POINTER" "OBJECT" "POINTER" "INT") | |
| 257 ("POINTER" "OBJECT" "POINTER" "POINTER" "ARRAY" "INT" "POINTER" "POINTER" "POINTER" "POINTER" "BOOL" "BOOL") | |
| 258 ("POINTER" "OBJECT" "POINTER") | |
| 259 ("POINTER" "OBJECT") | |
| 260 ("POINTER" "POINTER") | |
| 833 | 261 ("POINTER" "STRING" "INT") |
| 462 | 262 ("POINTER") |
| 263 ("STRING" "INT" "INT" "INT") | |
| 264 ("STRING" "INT") | |
| 265 ("STRING" "OBJECT" "BOOL") | |
| 266 ("STRING" "OBJECT" "FLOAT") | |
| 267 ("STRING" "OBJECT" "INT" "INT") | |
| 268 ("STRING" "OBJECT" "INT") | |
| 269 ("STRING" "OBJECT") | |
| 270 ("STRING" "POINTER" "STRING") | |
| 271 ("STRING" "POINTER") | |
| 272 ("STRING") | |
| 273 ) | |
| 274 ) | |
| 275 ) | |
| 276 (mapc (lambda (x) (apply 'define-marshaller x)) todo) | |
| 277 | |
| 278 (insert "\n | |
| 279 #include \"hash.h\" | |
| 608 | 280 |
| 281 static struct hash_table *marshaller_hashtable; | |
| 462 | 282 |
| 283 static void initialize_marshaller_storage (void) | |
| 284 { | |
| 285 if (!marshaller_hashtable) | |
| 286 { | |
| 2523 | 287 marshaller_hashtable = make_string_hash_table (100); |
| 462 | 288 ") |
| 289 | |
| 290 (mapc (lambda (x) | |
| 291 (let ((name (get-marshaller-name (car x) (cdr x)))) | |
| 292 (insert (format "\t\tputhash (\"%s\", (void *) %s, marshaller_hashtable);\n" name name)))) | |
| 293 todo) | |
| 294 (insert "\t};\n" | |
| 295 "}\n" | |
| 296 " | |
| 297 static void *find_marshaller (const char *func_name) | |
| 298 { | |
| 299 void *fn = NULL; | |
| 300 initialize_marshaller_storage (); | |
| 301 | |
| 591 | 302 if (gethash (func_name, marshaller_hashtable, (const void **)&fn)) |
| 462 | 303 { |
| 304 return (fn); | |
| 305 } | |
| 306 | |
| 307 return (NULL); | |
| 308 } | |
| 309 ")) | |
| 310 | |
| 311 (save-buffer) | |
| 312 (kill-buffer "emacs-marshals.c")) |