1;;;; build-gtk.jl -- translate guile-gtk .defs file to rep C code 2;;; Copyright (C) 1999 John Harper <john@dcs.warwick.ac.uk> 3;;; $Id$ 4;;; 5;;; This program is free software; you can redistribute it and/or modify 6;;; it under the terms of the GNU General Public License as published by 7;;; the Free Software Foundation; either version 2, or (at your option) 8;;; any later version. 9;;; 10;;; This program is distributed in the hope that it will be useful, 11;;; but WITHOUT ANY WARRANTY; without even the implied warranty of 12;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the 13;;; GNU General Public License for more details. 14;;; 15;;; You should have received a copy of the GNU General Public License 16;;; along with this software; see the file COPYING. If not, write to 17;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA. 18 19(provide 'build-gtk) 20 21(setq debug-on-error '(bad-arg invalid-function missing-arg)) 22 23;; Notes: 24 25;; This assumes that the `sed-fix-defs' sed script has been run over all 26;; input files (to convert schemey things to their lispy equivalents) 27 28;; Todo: 29;; * doesn't check for `listable' type-property 30;; * guile-gtk `struct' and `ptype' types 31;; * not possible to wrap functions returning vector types 32 33;; WARNING: This makes some pretty gruesome assumptions. [where?] 34 35;; Configuration 36 37;; Alist of (TYPE ["C-TYPE" | DECL-FUNC] ["REP2GTK" | FROM-REP-FUNC] 38;; ["GTK2REP" | TO-REP-FUNC] ["PRED-NAME" | PRED-FUNC] 39;; . OPTION-ALIST) 40 41;; The required functions are called as: 42 43;; (DECL-FUNC TYPE TYPE-INFO) 44;; (FROM-REP-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS) 45;; (TO-REP-FUNC OUTPUT-STREAM TYPE "GTK-VAR" TYPE-INFO OPTIONS) 46;; (PRED-FUNC OUTPUT-STREAM TYPE "REP-VAR" TYPE-INFO OPTIONS) 47 48;; The options in the OPTION-ALIST may be: 49 50;; (c2args . EMIT-ARG-FUNC) 51;; (finish . FINISH-ARG-FUNC) 52;; (listable . BOOLEAN) 53 54;; with: 55 56;; (EMIT-ARG-FUNC OUTPUT TYPE "GTK-VAR" OPTIONS) 57;; (FINISH-ARG-FUNC OUTPUT TYPE "GTK-VAR" "REP-VAR" OPTIONS) 58 59(defvar gtk-type-alist nil) 60 61(defun define-type (type c-type rep-to-gtk gtk-to-rep type-pred . options) 62 (setq gtk-type-alist (cons (list* type c-type rep-to-gtk 63 gtk-to-rep type-pred options) 64 gtk-type-alist))) 65 66;; Work variables 67 68(defvar gtk-enums nil 69 "List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs") 70 71(defvar gtk-string-enums nil 72 "List of (ENUM-NAME . ENUM-DEF) for all parsed enums defs") 73 74(defvar gtk-flags nil 75 "List of (ENUM-NAME . ENUM-DEF) for all parsed flags defs") 76 77(defvar gtk-boxed nil 78 "List of (BOXED-NAME . BOXED-DEF)") 79 80(defvar gtk-objects nil 81 "List of (OBJECT-NAME . OBJECT-DEF)") 82 83(defvar gtk-functions nil 84 "List of (FUNCTION-NAME . FUNCTION-DEF)") 85 86(defvar gtk-options nil 87 "List of (OPTION VALUE)") 88 89(defvar gtk-subrs nil 90 "List of C-NAME.") 91 92;; similar for imported files 93(defvar gtk-imported-enums nil) 94(defvar gtk-imported-string-enums nil) 95(defvar gtk-imported-flags nil) 96(defvar gtk-imported-boxed nil) 97(defvar gtk-imported-objects nil) 98 99;; t when importing secondary definitions 100(defvar gtk-importing nil) 101 102(defmacro gtk-get-options (name options) 103 `(cdr (assq ,name ,options))) 104 105(defmacro gtk-get-option (name options) 106 `(car (gtk-get-options ,name ,options))) 107 108(defvar gtk-hyphen-map 109 (let 110 ((map (make-string (1+ ?_))) 111 (i 0)) 112 (while (< i ?_) 113 (aset map i i) 114 (setq i (1+ i))) 115 (aset map i ?-) 116 map)) 117 118(defvar gtk-unhyphen-map 119 (let 120 ((map (make-string (1+ ?-))) 121 (i 0)) 122 (while (< i ?-) 123 (aset map i i) 124 (setq i (1+ i))) 125 (aset map i ?_) 126 map)) 127 128(defvar gtk-emitted-composite-helpers nil) 129 130;; Entry point 131 132(defun build-gtk (defs-file-name output-file-name) 133 (let 134 ((gtk-enums nil) 135 (gtk-string-enums nil) 136 (gtk-flags nil) 137 (gtk-boxed nil) 138 (gtk-objects nil) 139 (gtk-functions nil) 140 (gtk-options nil) 141 (gtk-subrs nil) 142 (gtk-imported-enums nil) 143 (gtk-imported-string-enums nil) 144 (gtk-imported-flags nil) 145 (gtk-imported-boxed nil) 146 (gtk-imported-objects nil) 147 (gtk-importing nil) 148 (gtk-emitted-composite-helpers nil)) 149 (let 150 ((defs-file (open-file defs-file-name 'read))) 151 (or defs-file (error "Can't open input file: %s" defs-file-name)) 152 (unwind-protect 153 (parse-gtk defs-file) 154 (close-file defs-file))) 155 (setq gtk-enums (nreverse gtk-enums)) 156 (setq gtk-string-enums (nreverse gtk-string-enums)) 157 (setq gtk-flags (nreverse gtk-flags)) 158 (setq gtk-boxed (nreverse gtk-boxed)) 159 (setq gtk-objects (nreverse gtk-objects)) 160 (setq gtk-functions (nreverse gtk-functions)) 161 (let 162 ((output-file (open-file output-file-name 'write))) 163 (or output-file (error "Can't open output file: %s" output-file-name)) 164 (unwind-protect 165 (let 166 ((standard-output output-file)) 167 (output-gtk output-file)) 168 (close-file output-file))))) 169 170(defun build-gtk-batch () 171 (or (= (length command-line-args) 2) (error "usage: INPUT OUTPUT")) 172 (let 173 ((in (car command-line-args)) 174 (out (nth 1 command-line-args))) 175 (setq command-line-args (nthcdr 2 command-line-args)) 176 (build-gtk in out))) 177 178;; Parsing 179 180(defun parse-gtk (input) 181 (condition-case nil 182 (while t 183 (let 184 ((def (read input))) 185 ;;(format standard-error "read: %S\n" def) 186 (when def 187 (or (consp def) (error "Definition isn't a list")) 188 (cond 189 ((memq (car def) '(include import)) 190 (let 191 ((file (open-file (expand-file-name (nth 1 def) 192 (file-name-directory 193 (file-binding input))) 194 'read))) 195 (or file (error "Can't open input file: %s" (nth 1 def))) 196 (unwind-protect 197 (let ((gtk-importing (if (eq (car def) 'import) 198 t 199 gtk-importing))) 200 (parse-gtk file)) 201 (close-file file)))) 202 ((eq (car def) 'define-enum) 203 (let* 204 ((name (nth 1 def)) 205 (body (nthcdr 2 def)) 206 (cell (or (assq name gtk-enums) 207 (assq name gtk-imported-enums)))) 208 (if cell 209 (rplacd cell body) 210 (if (not gtk-importing) 211 (setq gtk-enums (cons (cons name body) gtk-enums)) 212 (setq gtk-imported-enums 213 (cons (cons name body) gtk-imported-enums)))))) 214 ((eq (car def) 'define-string-enum) 215 (let* 216 ((name (nth 1 def)) 217 (body (nthcdr 2 def)) 218 (cell (or (assq name gtk-string-enums) 219 (assq name gtk-imported-string-enums)))) 220 (if cell 221 (rplacd cell body) 222 (if (not gtk-importing) 223 (setq gtk-string-enums (cons (cons name body) 224 gtk-string-enums)) 225 (setq gtk-imported-string-enums 226 (cons (cons name body) 227 gtk-imported-string-enums)))))) 228 ((eq (car def) 'define-flags) 229 (let* 230 ((name (nth 1 def)) 231 (body (nthcdr 2 def)) 232 (cell (or (assq name gtk-flags) 233 (assq name gtk-imported-flags)))) 234 (if cell 235 (rplacd cell body) 236 (if (not gtk-importing) 237 (setq gtk-flags (cons (cons name body) gtk-flags)) 238 (setq gtk-imported-flags 239 (cons (cons name body) gtk-imported-flags)))))) 240 ((eq (car def) 'define-boxed) 241 (let 242 ((cell (or (assq (nth 1 def) gtk-boxed) 243 (assq (nth 1 def) gtk-imported-boxed)))) 244 (if cell 245 (rplacd cell (nthcdr 2 def)) 246 (if (not gtk-importing) 247 (setq gtk-boxed (cons (cdr def) gtk-boxed)) 248 (setq gtk-imported-boxed 249 (cons (cdr def) gtk-imported-boxed)))))) 250 ((eq (car def) 'define-object) 251 (let* 252 ((name (nth 1 def)) 253 (super (nth 2 def)) 254 (attrs (nthcdr 3 def)) 255 (cell (or (assq name gtk-objects) 256 (assq name gtk-imported-objects)))) 257 (when (car super) 258 (setq attrs (cons (cons 'super (car super)) attrs))) 259 (if cell 260 (rplacd cell attrs) 261 (if (not gtk-importing) 262 (setq gtk-objects 263 (cons (cons name attrs) gtk-objects)) 264 (setq gtk-imported-objects 265 (cons (cons name attrs) gtk-imported-objects)))))) 266 ((eq (car def) 'define-func) 267 (unless gtk-importing 268 (let 269 ((cell (assq (nth 1 def) gtk-functions))) 270 (if cell 271 (rplacd cell (nthcdr 2 def)) 272 (setq gtk-functions (cons (cdr def) gtk-functions)))))) 273 ((eq (car def) 'define-type) 274 (eval def)) 275 ((eq (car def) 'options) 276 (unless gtk-importing 277 (mapc (lambda (cell) 278 (let 279 ((value (assq (car cell) gtk-options))) 280 (if value 281 (rplacd value (nconc (cdr value) 282 (list (nth 1 cell)))) 283 (setq gtk-options (cons cell gtk-options))))) 284 (cdr def)))) 285 ((eq (car def) 'add-options) 286 (unless gtk-importing 287 (let 288 ((value (assq (nth 1 def) gtk-options))) 289 (if value 290 (rplacd value (nconc (cdr value) (nthcdr 2 def))) 291 (setq gtk-options (cons (cdr def) gtk-options)))))) 292 (t 293 (gtk-warning "Ignoring `%S'" def)))))) 294 (end-of-stream))) 295 296;; Code generation 297 298(defmacro @ args 299 (list* 'format 'output args)) 300 301(defun output-header (output) 302 (@ "/* Automatically generated by build-gtk, DO NOT EDIT! */\n\n") 303 (when (gtk-get-options 'includes gtk-options) 304 (mapc (lambda (opt) 305 (@ "%s\n" opt)) 306 (gtk-get-options 'includes gtk-options))) 307 (@ "#include <rep/rep.h>\n") 308 (@ "#include \"rep-gtk.h\"\n\n")) 309 310(defun output-footer (output) 311 (let* 312 ((feature (gtk-get-option 'provide gtk-options)) 313 (aliases (gtk-get-options 'alias gtk-options)) 314 (init (gtk-get-option 'init-func gtk-options))) 315 (when feature 316 (@ "\nrepv\nrep_dl_init \(void\)\n{\n") 317 (@ " repv s = rep_push_structure \(\"%s\"\);\n" feature) 318 (mapc (lambda (a) 319 (@ " /* ::alias:%s %s:: */\n" a feature) 320 (@ " rep_alias_structure \(\"%s\"\);\n" a)) aliases) 321 (when init 322 (@ "\n %s \(\);\n\n" init)) 323 (@ " return rep_pop_structure \(s\);\n") 324 (@ "}\n")))) 325 326(defun output-imported-enums (output) 327 (when gtk-imported-enums 328 (@ "\f\n/* Imported enums */\n\n") 329 (mapc (lambda (enum) 330 (let* 331 ((cname (gtk-canonical-name (symbol-name (car enum))))) 332 (@ "extern sgtk_enum_info sgtk_%s_info;\n" cname))) 333 gtk-imported-enums) 334 (@ "\n"))) 335 336(defun output-enums (output) 337 (when gtk-enums 338 (@ "\f\n/* Enums definitions */\n\n") 339 (mapc (lambda (enum) 340 (let* 341 ((name (car enum)) 342 (cname (gtk-canonical-name (symbol-name name))) 343 (values (cdr enum))) 344 ;; write literal names 345 (@ "static sgtk_enum_literal _%s_literals[%d] = {\n" 346 cname (length values)) 347 (mapc (lambda (cell) 348 (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) 349 values) 350 (@ "};\n") 351 ;; write type info struct 352 (@ "sgtk_enum_info sgtk_%s_info = {\n" cname) 353 (@ " { \"%s\", G_TYPE_ENUM }, %d, _%s_literals,\n" 354 name (length values) cname) 355 (@ "};\n\n"))) 356 gtk-enums))) 357 358(defun output-imported-string-enums (output) 359 (when gtk-imported-string-enums 360 (@ "\f\n/* Imported string enums */\n\n") 361 (mapc (lambda (enum) 362 (let* 363 ((cname (gtk-canonical-name (symbol-name (car enum))))) 364 (@ "extern sgtk_string_enum_info sgtk_%s_info;\n" cname))) 365 gtk-imported-string-enums) 366 (@ "\n"))) 367 368(defun output-string-enums (output) 369 (when gtk-string-enums 370 (@ "\f\n/* String enums definitions */\n\n") 371 (mapc (lambda (enum) 372 (let* 373 ((name (car enum)) 374 (cname (gtk-canonical-name (symbol-name name))) 375 (values (cdr enum))) 376 ;; write literal names 377 (@ "static sgtk_senum_literal _%s_literals[%d] = {\n" 378 cname (length values)) 379 (mapc (lambda (cell) 380 (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) 381 values) 382 (@ "};\n") 383 ;; write type info struct 384 (@ "sgtk_senum_info sgtk_%s_info = {\n" cname) 385 (@ " { \"%s\", G_TYPE_INVALID }, %d, _%s_literals,\n" 386 name (length values) cname) 387 (@ "};\n\n"))) 388 gtk-string-enums))) 389 390(defun output-imported-flags (output) 391 (when gtk-imported-flags 392 (@ "\f\n/* Imported flags */\n\n") 393 (mapc (lambda (flag) 394 (let* 395 ((cname (gtk-canonical-name (symbol-name (car flag))))) 396 (@ "extern sgtk_enum_info sgtk_%s_info;\n" cname))) 397 gtk-imported-flags) 398 (@ "\n"))) 399 400(defun output-flags (output) 401 (when gtk-flags 402 (@ "\f\n/* Flags definitions */\n\n") 403 (mapc (lambda (flag) 404 (let* 405 ((name (car flag)) 406 (cname (gtk-canonical-name (symbol-name name))) 407 (values (cdr flag))) 408 ;; write literal names 409 (@ "static sgtk_enum_literal _%s_literals[%d] = {\n" 410 cname (length values)) 411 (mapc (lambda (cell) 412 (@ " { \"%s\", %s },\n" (car cell) (nth 1 cell))) 413 values) 414 (@ "};\n") 415 ;; write type info struct 416 (@ "sgtk_enum_info sgtk_%s_info = {\n" cname) 417 (@ " { \"%s\", G_TYPE_FLAGS }, %d, _%s_literals,\n" 418 name (length values) cname) 419 (@ "};\n\n"))) 420 gtk-flags))) 421 422(defun output-imported-boxed (output) 423 (when gtk-imported-boxed 424 (@ "\f\n/* Imported boxed structures */\n\n") 425 (mapc (lambda (boxed) 426 (let* 427 ((cname (gtk-canonical-name (symbol-name (car boxed))))) 428 (@ "extern sgtk_boxed_info sgtk_%s_info;\n" cname))) 429 gtk-imported-boxed) 430 (@ "\n"))) 431 432(defun output-boxed (output) 433 (when gtk-boxed 434 (@ "\f\n/* Boxed structure definitions */\n\n") 435 (mapc (lambda (boxed) 436 (let* 437 ((name (car boxed)) 438 (cname (gtk-canonical-name (symbol-name name))) 439 (attrs (cdr boxed)) 440 (conv (car (cdr (assq 'conversion attrs))))) 441 (when conv 442 (@ "repv %s (repv);\n" conv)) 443 (@ "sgtk_boxed_info sgtk_%s_info = {\n" cname) 444 (@ " { \"%s\", G_TYPE_BOXED, %s },\n" name (or conv "NULL")) 445 (@ " (void *(*)(void*))%s,\n" 446 (or (car (cdr (assq 'copy attrs))) "NULL")) 447 (@ " (void (*)(void*))%s,\n" 448 (or (car (cdr (assq 'free attrs))) "NULL")) 449 (@ " %s\n" 450 (or (car (cdr (assq 'size attrs))) 0)) 451 (@ "};\n\n"))) 452 gtk-boxed))) 453 454(defun output-imported-objects (output) 455 (when gtk-imported-objects 456 (@ "\f\n/* Imported GTK objects */\n\n") 457 (mapc (lambda (obj) 458 (let* 459 ((cname (gtk-canonical-name (symbol-name (car obj))))) 460 (@ "extern sgtk_object_info sgtk_%s_info;\n" cname))) 461 gtk-imported-objects) 462 (@ "\n"))) 463 464(defun output-objects (output) 465 (when gtk-objects 466 (@ "\f\n/* GTK object definitions */\n\n") 467 (mapc (lambda (obj) 468 (let* 469 ((name (car obj)) 470 (cname (gtk-canonical-name (symbol-name name)))) 471 (@ "sgtk_object_info sgtk_%s_info = {\n" cname) 472 (@ " { \"%s\", G_TYPE_OBJECT }, %s_get_type\n" name cname) 473 (@ "};\n\n"))) gtk-objects))) 474 475(defun output-type-info (output) 476 (when (or gtk-enums gtk-flags gtk-boxed gtk-objects) 477 (@ "\f\n/* Vector of all type information */\n\n") 478 (@ "static sgtk_type_info *_type_infos[] = {\n") 479 (mapc (lambda (lst) 480 (mapc (lambda (type) 481 (@ " (sgtk_type_info*)&sgtk_%s_info,\n" 482 (gtk-canonical-name (symbol-name (car type))))) 483 lst)) 484 (list gtk-enums gtk-string-enums gtk-flags gtk-boxed gtk-objects)) 485 (@ " NULL\n};\n\n"))) 486 487(defun output-functions (output) 488 (@ "\f\n/* Defuns */\n\n") 489 (mapc (lambda (fun) 490 (let 491 ;; send output to a temporary buffer to allow helper 492 ;; functions to be emitted asynchronously 493 ((temporary-stream (make-string-output-stream))) 494 (output-function fun temporary-stream) 495 (write output (get-output-stream-string temporary-stream)))) 496 gtk-functions) 497 (@ "\n\n")) 498 499(defun output-subrs (output) 500 (@ "\f\n/* Initialisation */\n\n") 501 (let 502 ((init-func (gtk-get-option 'init-func gtk-options)) 503 (other-inits (gtk-get-options 'other-inits gtk-options)) 504 (extra-init (gtk-get-options 'extra-init-code gtk-options)) 505 (system-init (gtk-get-options 'system-init-code gtk-options))) 506 (when init-func 507 (@ "void\n%s (void)\n{\n" init-func) 508 (@ " static int done;\n if (!done)\n {\n") 509 (@ " done = 1;\n") 510 (mapc (lambda (func) 511 (@ " %s ();\n" func)) other-inits) 512 (when (or gtk-enums gtk-string-enums gtk-flags gtk-boxed gtk-objects) 513 (@ " sgtk_register_type_infos (_type_infos);\n")) 514 (mapc (lambda (cname) 515 (@ " rep_ADD_SUBR(S%s);\n" cname)) (nreverse gtk-subrs)) 516 (mapc (lambda (code) 517 (declare (unused code)) 518 (@ " %s\n")) extra-init) 519 (when system-init 520 (@ " {\n") 521 (@ " char *tem = getenv (\"REP_GTK_DONT_INITIALIZE\");\n") 522 (@ " if (tem == 0 || atoi (tem) == 0) {\n") 523 (mapc (lambda (code) 524 (@ " %s\n" code)) system-init) 525 (@ " }\n") 526 (@ " }\n")) 527 (@ " \}\n\}\n")))) 528 529(defun output-gtk (output) 530 (output-header output) 531 (output-imported-enums output) 532 (output-imported-string-enums output) 533 (output-imported-flags output) 534 (output-imported-boxed output) 535 (output-imported-objects output) 536 (output-enums output) 537 (output-string-enums output) 538 (output-flags output) 539 (output-boxed output) 540 (output-objects output) 541 (output-functions output) 542 (output-field-functions gtk-boxed output) 543 (output-field-functions gtk-objects output) 544 (output-type-info output) 545 (output-subrs output) 546 (output-footer output)) 547 548;; Type management 549 550(defun gtk-outer-type (type) 551 (while (consp type) 552 (setq type (car type))) 553 type) 554 555(defun gtk-inner-type (type) 556 (while (consp (car type)) 557 (setq type (car type))) 558 (nth 1 type)) 559 560(defun gtk-composite-type-mode (type) 561 (while (consp (car type)) 562 (setq type (car type))) 563 (case (car type) 564 ((ret) 'out) 565 ((fvec) (or (nth 3 type) 'in)) 566 (t (or (nth 2 type) 'in)))) 567 568(defun gtk-composite-type-len (type) 569 (while (consp (car type)) 570 (setq type (car type))) 571 (case (car type) 572 ((ret) 1) 573 ((fvec) (nth 2 type)) 574 (t nil))) 575 576(defun gtk-type-info (type) 577 (let* 578 ((actual-type (gtk-outer-type type)) 579 (typage (cond ((or (assq actual-type gtk-enums) 580 (assq actual-type gtk-imported-enums)) 581 (assq 'enum gtk-type-alist)) 582 ((or (assq actual-type gtk-string-enums) 583 (assq actual-type gtk-imported-string-enums)) 584 (assq 'senum gtk-type-alist)) 585 ((or (assq actual-type gtk-flags) 586 (assq actual-type gtk-imported-flags)) 587 (assq 'flags gtk-type-alist)) 588 ((or (assq actual-type gtk-boxed) 589 (assq actual-type gtk-imported-boxed)) 590 (assq 'boxed gtk-type-alist)) 591 ((or (assq actual-type gtk-objects) 592 (assq actual-type gtk-imported-objects)) 593 (assq 'object gtk-type-alist)) 594 (t 595 (assq actual-type gtk-type-alist))))) 596 (or typage (error "Unknown type: %s" type)))) 597 598(defmacro gtk-typage-prop (typage prop) 599 `(cdr (assq ,prop (nthcdr 5 ,typage)))) 600 601(defun gtk-type-decl (type typage) 602 (let 603 ((decl (nth 1 typage))) 604 (if (functionp decl) 605 (funcall decl type typage) 606 decl))) 607 608(defmacro gtk-type-fromrep (typage) 609 `(nth 2 ,typage)) 610 611(defmacro gtk-type-torep (typage) 612 `(nth 3 ,typage)) 613 614(defmacro gtk-type-pred (typage) 615 `(nth 4 ,typage)) 616 617(defun gtk-type-prop (type prop) 618 (gtk-typage-prop (gtk-type-info type) prop)) 619 620;; Function arg helpers 621 622(defmacro gtk-get-arg-options (option arg) 623 `(assq ,option (nthcdr 2 ,arg))) 624 625(defun gtk-arg-optional-p (arg) 626 (nth 1 (gtk-get-arg-options '= arg))) 627 628(defmacro gtk-arg-type (arg) 629 `(car ,arg)) 630 631(defmacro gtk-arg-name (arg) 632 `(symbol-name (nth 1 ,arg))) 633 634;; Type output functions 635 636(defun output-complex-type (type typage) 637 (declare (unused typage)) 638 (setq type (gtk-outer-type type)) 639 (if (or (assq type gtk-enums) (assq type gtk-imported-enums) 640 (assq type gtk-flags) (assq type gtk-imported-flags)) 641 (symbol-name type) 642 (format nil "%s*" type))) 643 644(define (output-rep-to-static x) 645 (lambda (output type rep-var typage) 646 (setq type (gtk-outer-type type)) 647 (let ((name (gtk-canonical-name (symbol-name type)))) 648 (@ "\(%s\) sgtk_rep_to_%s \(%s, &sgtk_%s_info\)" 649 (gtk-type-decl type typage) x rep-var name)))) 650 651(define (output-static-to-rep x) 652 (lambda (output type gtk-var typage) 653 (declare (unused typage)) 654 (setq type (gtk-outer-type type)) 655 (let ((name (gtk-canonical-name (symbol-name type)))) 656 (@ "sgtk_%s_to_rep \(%s, &sgtk_%s_info\)" x gtk-var name)))) 657 658(define (output-static-pred x) 659 (lambda (output type rep-var typage) 660 (declare (unused typage)) 661 (@ "sgtk_valid_%s \(%s, &sgtk_%s_info\)" 662 x rep-var (gtk-canonical-name (symbol-name type))))) 663 664(define output-rep-to-enum (output-rep-to-static 'enum)) 665(define output-enum-to-rep (output-static-to-rep 'enum)) 666(define output-enum-pred (output-static-pred 'enum)) 667 668(define output-rep-to-senum (output-rep-to-static 'senum)) 669(define output-senum-to-rep (output-static-to-rep 'senum)) 670(define output-senum-pred (output-static-pred 'senum)) 671 672(define output-rep-to-flags (output-rep-to-static 'flags)) 673(define output-flags-to-rep (output-static-to-rep 'flags)) 674(define output-flags-pred (output-static-pred 'flags)) 675 676(defun output-rep-to-boxed (output type rep-var typage) 677 (declare (unused typage)) 678 (setq type (gtk-outer-type type)) 679 (@ "\(%s*\) sgtk_rep_to_boxed \(%s\)" type rep-var)) 680 681(defun output-boxed-to-rep (output type gtk-var typage) 682 (declare (unused typage)) 683 (let* 684 ((base-type (gtk-outer-type type)) 685 (name (gtk-canonical-name (symbol-name base-type))) 686 (copy (if (assq 'copy (cdr type)) 687 (gtk-get-option 'copy (cdr type)) 688 t))) 689 (@ "sgtk_boxed_to_rep \(%s, &sgtk_%s_info, %d\)" 690 gtk-var name (if copy 1 0)))) 691 692(defun output-boxed-pred (output type rep-var typage) 693 (declare (unused typage)) 694 (@ "sgtk_valid_boxed \(%s, &sgtk_%s_info\)" 695 rep-var (gtk-canonical-name (symbol-name type)))) 696 697(defun output-rep-to-object (output type rep-var typage) 698 (declare (unused typage)) 699 (setq type (gtk-outer-type type)) 700 (@ "\(%s*\) sgtk_get_gobj \(%s\)" type rep-var)) 701 702(defun output-object-to-rep (output type gtk-var typage) 703 (declare (unused typage)) 704 (setq type (gtk-outer-type type)) 705 (@ "sgtk_wrap_gobj \(\(GObject*\) %s\)" gtk-var)) 706 707(defun output-object-pred (output type rep-var typage) 708 (declare (unused typage)) 709 (@ "sgtk_is_a_gobj \(%s_get_type \(\), %s\)" 710 (gtk-canonical-name (symbol-name type)) rep-var)) 711 712(defun output-rep-to-full-callback (output type rep-var typage options) 713 (declare (unused typage type)) 714 (let 715 ((protect (gtk-get-option 'protection options))) 716 (cond ((eq protect '*result*) 717 (@ "sgtk_new_protect \(%s\)" rep-var)) 718 ((and (not (eq protect t)) 719 (not (eq protect nil))) 720 (@ "sgtk_protect \(p_%s, %s\)" protect rep-var)) 721 (t 722 (@ "sgtk_protect \(Qt, %s\)" rep-var))))) 723 724(defun output-full-callback-args (output type var options) 725 (declare (unused typage type options)) 726 (@ "0, sgtk_callback_marshal, (gpointer)%s, sgtk_callback_destroy" var)) 727 728(defun output-full-callback-finish (output type g-var r-var options) 729 (declare (unused typage type r-var)) 730 (let 731 ((protect (gtk-get-option 'protection options))) 732 (when (eq protect '*result*) 733 (@ " sgtk_set_protect \(pr_ret, %s\);\n" g-var)))) 734 735(defun output-rep-to-gclosure (output type rep-var typage options) 736 (declare (unused typage type)) 737 (let 738 ((protect (gtk-get-option 'protection options))) 739 (cond ((eq protect '*result*) 740 (@ "sgtk_new_gclosure \(%s\)" rep-var)) 741 ((and (not (eq protect t)) 742 (not (eq protect nil))) 743 (@ "sgtk_gclosure \(p_%s, %s\)" protect rep-var)) 744 (t 745 (@ "sgtk_gclosure \(Qt, %s\)" rep-var))))) 746 747(defun output-gclosure-finish (output type g-var r-var options) 748 (declare (unused typage type r-var)) 749 (let 750 ((protect (gtk-get-option 'protection options))) 751 (when (eq protect '*result*) 752 (@ " sgtk_set_gclosure \(pr_ret, %s\);\n" g-var)))) 753 754(defun output-rep-to-cvec (output type rep-var typage) 755 (declare (unused typage)) 756 (let* 757 ((inner-type (gtk-inner-type type)) 758 (inner-typage (gtk-type-info inner-type)) 759 (decl (gtk-type-decl inner-type inner-typage)) 760 (mode (gtk-composite-type-mode type))) 761 (output-helper inner-type standard-output) 762 (@ "sgtk_rep_to_cvec \(%s, %s, sizeof \(%s\)\)" 763 rep-var 764 (if (eq mode 'out) 765 "0" 766 (format nil "_sgtk_helper_fromrep_%s" inner-type)) 767 decl))) 768 769(defun output-cvec-to-rep (output type gtk-var typage) 770 (declare (unused typage)) 771 (let* 772 ((inner-type (gtk-inner-type type)) 773 (inner-typage (gtk-type-info inner-type)) 774 (decl (gtk-type-decl inner-type inner-typage))) 775 (output-helper inner-type standard-output) 776 (@ "sgtk_cvec_to_rep \(&%s, _sgtk_helper_torep_copy_%s, sizeof \(%s\)\)" 777 gtk-var inner-type decl))) 778 779(defun output-cvec-pred (output type rep-var typage) 780 (declare (unused typage)) 781 (let* 782 ((inner-type (gtk-inner-type type)) 783 (mode (gtk-composite-type-mode type)) 784 (len (gtk-composite-type-len type))) 785 (output-helper inner-type standard-output) 786 (if len 787 (@ "sgtk_valid_complen \(%s, %s, %s\)" 788 rep-var 789 (if (eq mode 'out) 790 ;; `out', so don't check inner validity 791 "NULL" 792 (concat "_sgtk_helper_valid_" (symbol-name inner-type))) 793 len) 794 (@ "sgtk_valid_composite \(%s, _sgtk_helper_valid_%s\)" 795 rep-var inner-type)))) 796 797(defun output-cvec-args (output type var options) 798 (declare (unused typage options)) 799 (let* 800 ((outer-type (gtk-outer-type type)) 801 (inner-type (gtk-inner-type type)) 802 (inner-typage (gtk-type-info inner-type)) 803 (decl (gtk-type-decl inner-type inner-typage))) 804 (cond ((eq outer-type 'cvec) 805 (@ "%s.count, \(%s*\) %s.vec" var decl var)) 806 ((eq outer-type 'cvecr) 807 (@ "\(%s*\) %s.vec, %s.count" decl var var)) 808 ((memq outer-type '(fvec ret tvec)) 809 (@ "\(%s*\) %s.vec" decl var)) 810 (t 811 (gtk-warning "Don't know how to pass type %s" type))))) 812 813(defun output-cvec-finish (output type gtk-var rep-var options) 814 (declare (unused typage options)) 815 (let* 816 ((inner-type (gtk-inner-type type)) 817 (inner-typage (gtk-type-info inner-type)) 818 (decl (gtk-type-decl inner-type inner-typage)) 819 (mode (gtk-composite-type-mode type))) 820 (@ " sgtk_cvec_finish \(&%s, %s, %s, sizeof \(%s\)\);\n" 821 gtk-var rep-var 822 (if (eq mode 'in) 823 "0" 824 (format nil "_sgtk_helper_torep_nocopy_%s" inner-type)) 825 decl))) 826 827(defun output-rep-to-list (output type rep-var typage) 828 (declare (unused typage)) 829 (let 830 ((outer-type (gtk-outer-type type)) 831 (inner-type (gtk-inner-type type))) 832 (output-helper inner-type standard-output) 833 (@ "sgtk_rep_to_%s \(%s, _sgtk_helper_fromrep_%s\)" 834 outer-type rep-var inner-type))) 835 836(defun output-list-to-rep (output type gtk-var typage) 837 (declare (unused typage)) 838 (let 839 ((outer-type (gtk-outer-type type)) 840 (inner-type (gtk-inner-type type))) 841 (output-helper inner-type standard-output) 842 (@ "sgtk_%s_to_rep \(%s, _sgtk_helper_torep_copy_%s\)" 843 outer-type gtk-var inner-type))) 844 845(defun output-list-finish (output type gtk-var rep-var options) 846 (declare (unused typage options)) 847 (let 848 ((outer-type (gtk-outer-type type)) 849 (inner-type (gtk-inner-type type)) 850 (mode (gtk-composite-type-mode type))) 851 (@ " sgtk_%s_finish \(%s, %s, %s\);\n" 852 outer-type gtk-var rep-var 853 (if (eq mode 'in) 854 "0" 855 (format nil "_sgtk_helper_torep_nocopy_%s" inner-type))))) 856 857;; Function generation 858 859(defun output-function (def output #!optional function-callback) 860 (let* 861 ((ret (nth 1 def)) 862 (args (nth 2 def)) 863 (options (nthcdr 3 def)) 864 (fname (symbol-name (car def))) 865 (rname (or (gtk-get-option 'scm-name options) 866 (gtk-hyphenate-name fname))) 867 (cname (gtk-unhyphenate-name rname)) 868 (subrtype (if (or (> (length args) 5) 869 (gtk-get-option 'rest-arg options)) 870 'n 871 (length args)))) 872 (setq gtk-subrs (cons cname gtk-subrs)) 873 874 ;; output header 875 (@ "DEFUN\(\"%s\", F%s, S%s, \(" rname cname cname) 876 (if (eq subrtype 'n) 877 (@ "repv args") 878 (if (zerop subrtype) 879 (@ "void") 880 (let 881 ((tem args)) 882 (while tem 883 (@ "repv p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " "")) 884 (setq tem (cdr tem)))))) 885 (@ "\), rep_Subr%s\)\n{\n" (if (numberp subrtype) subrtype "N")) 886 (unless (eq ret 'none) 887 (@ " repv pr_ret;\n")) 888 (when (eq subrtype 'n) 889 (@ " repv ") 890 (let 891 ((tem args)) 892 (while tem 893 (@ "p_%s%s" (gtk-arg-name (car tem)) (if (cdr tem) ", " ";\n\n")) 894 (setq tem (cdr tem))))) 895 896 ;; output any gc roots required 897 (mapc (lambda (arg) 898 (when (or (gtk-get-arg-options 'protect-during arg) 899 (gtk-type-prop (gtk-arg-type arg) 'finish)) 900 (@ " rep_GC_root gc_%s;\n" (gtk-arg-name arg)))) args) 901 902 ;; output arg/ret decls 903 (mapc (lambda (arg) 904 (let* 905 ((type (gtk-arg-type arg)) 906 (typage (gtk-type-info type)) 907 (decl (gtk-type-decl type typage))) 908 (if (stringp decl) 909 (@ " %s c_%s;\n" decl (gtk-arg-name arg)) 910 (gtk-warning 911 "Don't know how to declare type: %s" type)))) args) 912 (when (gtk-get-option 'gerror-arg options) 913 (@ " GError* error = NULL;\n")) 914 (unless (eq ret 'none) 915 (let* 916 ((typage (gtk-type-info ret)) 917 (decl (gtk-type-decl ret typage))) 918 (cond 919 ((stringp decl) 920 (@ " %s cr_ret;\n" decl)) 921 ((functionp decl) 922 (funcall decl output ret "cr_ret" typage options)) 923 (t 924 (gtk-warning 925 "Don't know how to declare type: %s" ret))))) 926 (unless (and (null args) (eq ret 'none)) 927 (@ "\n")) 928 929 ;; break out the list of parameters 930 (when (eq subrtype 'n) 931 (let 932 ((tem args) 933 (i 1)) 934 (while tem 935 (@ " if \(!rep_CONSP\(args\)\)\n") 936 (@ " p_%s = Qnil; \n" (gtk-arg-name (car tem))) 937 (@ " else {\n") 938 (@ (if (and (null (cdr tem)) (gtk-get-option 'rest-arg options)) 939 " p_%s = args; args = Qnil;\n" 940 " p_%s = rep_CAR(args); args = rep_CDR(args);\n") 941 (gtk-arg-name (car tem))) 942 (@ " }\n") 943 (setq tem (cdr tem)) 944 (setq i (1+ i))) 945 (@ "\n"))) 946 947 ;; output arg checks and conversions 948 (let 949 ((tem args) 950 (i 1)) 951 (while tem 952 (let* 953 ((type (gtk-arg-type (car tem))) 954 (typage (gtk-type-info type)) 955 (pred (gtk-type-pred typage)) 956 (optional (gtk-arg-optional-p (car tem))) 957 (type-options (gtk-get-options type gtk-options))) 958 (when (gtk-get-option 'conversion type-options) 959 (@ " p_%s = %s \(p_%s\);\n" 960 (gtk-arg-name (car tem)) 961 (gtk-get-option 'conversion type-options) 962 (gtk-arg-name (car tem)))) 963 (unless (or optional (null pred)) 964 (when (gtk-get-arg-options 'null-ok (car tem)) 965 (@ " if (p_%s != Qnil)\n " (gtk-arg-name (car tem)))) 966 (@ " rep_DECLARE \(%d, p_%s, " i (gtk-arg-name (car tem))) 967 (cond ((stringp pred) 968 (@ "%s \(p_%s\)" pred (gtk-arg-name (car tem)))) 969 ((functionp pred) 970 (funcall pred output type 971 (concat "p_" (gtk-arg-name (car tem))) 972 typage options)) 973 (t 974 (gtk-warning "Don't know type predicate: %s" type))) 975 (@ "\);\n")) 976 (setq tem (cdr tem)) 977 (setq i (1+ i))))) 978 (when args 979 (@ "\n")) 980 981 ;; initialise gc roots 982 (mapc (lambda (arg) 983 (when (or (gtk-get-arg-options 'protect-during arg) 984 (gtk-type-prop (gtk-arg-type arg) 'finish)) 985 (@ " rep_PUSHGC \(gc_%s, p_%s\);\n" 986 (gtk-arg-name arg) (gtk-arg-name arg)))) args) 987 988 ;; output arg initialisations 989 (mapc (lambda (arg) 990 (let* 991 ((type (gtk-arg-type arg)) 992 (typage (gtk-type-info type)) 993 (from (gtk-type-fromrep typage)) 994 (optional (gtk-arg-optional-p arg))) 995 (when (gtk-get-arg-options 'null-ok arg) 996 (@ " if (p_%s == Qnil)\n c_%s = 0; \n else\n " 997 (gtk-arg-name arg) (gtk-arg-name arg))) 998 (when optional 999 (@ " if \(p_%s == Qnil\)\n c_%s = %s;\n else\n " 1000 (gtk-arg-name arg) (gtk-arg-name arg) optional)) 1001 (@ " c_%s = " (gtk-arg-name arg)) 1002 (cond ((stringp from) 1003 (@ "%s \(p_%s\)" from (gtk-arg-name arg))) 1004 ((functionp from) 1005 (funcall from output type 1006 (concat "p_" (gtk-arg-name arg)) 1007 typage options)) 1008 (t 1009 (gtk-warning 1010 "Don't know how to convert repv to %s" type))) 1011 (@ ";\n"))) args) 1012 (when args 1013 (@ "\n")) 1014 1015 (if function-callback 1016 (funcall function-callback output) 1017 ;; output call 1018 (@ " ") 1019 (unless (eq ret 'none) 1020 (@ "cr_ret = ")) 1021 (@ "%s \(" fname) 1022 (let 1023 ((tem args)) 1024 (while tem 1025 (let 1026 ((opt (gtk-type-prop (gtk-arg-type (car tem)) 'c2args))) 1027 (if opt 1028 (if (functionp opt) 1029 (funcall opt output (gtk-arg-type (car tem)) 1030 (concat "c_" (gtk-arg-name (car tem))) 1031 options) 1032 (gtk-warning "c2args function %s undefined" opt)) 1033 (@ "c_%s" (gtk-arg-name (car tem))))) 1034 (@ (if (cdr tem) ", " "")) 1035 (setq tem (cdr tem)))) 1036 (if (gtk-get-option 'gerror-arg options) 1037 (@ ", &error")) 1038 (@ "\);\n\n")) 1039 1040 ;; output ret conversion 1041 (unless (eq ret 'none) 1042 (let* 1043 ((typage (gtk-type-info ret)) 1044 (to (gtk-type-torep typage))) 1045 (@ " pr_ret = ") 1046 (cond ((stringp to) 1047 (@ "%s \(cr_ret\)" to)) 1048 ((functionp to) 1049 (funcall to output ret "cr_ret" typage options)) 1050 (t 1051 (gtk-warning 1052 "Don't know how to convert %s to repv" ret))) 1053 (@ ";\n"))) 1054 1055 ;; output `finish' options 1056 (mapc (lambda (arg) 1057 (let 1058 ((opt (gtk-type-prop (gtk-arg-type arg) 'finish))) 1059 (when opt 1060 (if (functionp opt) 1061 (funcall opt output (gtk-arg-type arg) 1062 (concat "c_" (gtk-arg-name arg)) 1063 (concat "p_" (gtk-arg-name arg)) 1064 options) 1065 (gtk-warning "finish function %s undefined" opt))))) args) 1066 1067 ;; pop gc roots 1068 (mapc (lambda (arg) 1069 (when (or (gtk-get-arg-options 'protect-during arg) 1070 (gtk-type-prop (gtk-arg-type arg) 'finish)) 1071 (@ " rep_POPGC;\n" 1072 (gtk-arg-name arg) (gtk-arg-name arg)))) args) 1073 1074 ;; gerror checking 1075 (when (gtk-get-option 'gerror-arg options) 1076 (@ " if (error != NULL)\n" ) 1077 (@ " sgtk_throw_gerror (\"%s\", error);\n" fname)) 1078 1079 ;; output return statement 1080 (if (eq ret 'none) 1081 (@ " return Qnil;\n") 1082 (@ " return pr_ret;\n")) 1083 1084 ;; footer 1085 (@ "}\n\n"))) 1086 1087;; Field access functions 1088 1089(defun output-field-functions (type-list output) 1090 (mapc (lambda (def) 1091 (let 1092 ((fields (cdr (assq 'fields (cdr def))))) 1093 (when fields 1094 (mapc #'(lambda (field) 1095 (output-field-accessors 1096 (car def) field output 1097 (car (cdr (assq 'setter (nthcdr 2 field)))) 1098 (car (cdr (assq 'getter (nthcdr 2 field)))))) 1099 fields)) 1100 (output-type-predicate (car def) output))) 1101 type-list)) 1102 1103(defun output-field-accessors (datatype field output #!optional settable getter) 1104 (let* 1105 ((type (car field)) 1106 (cdatatype (gtk-canonical-name (symbol-name datatype))) 1107 (cfieldname (symbol-name (nth 1 field)))) 1108 (output-function (list (intern (format nil "%s_%s" cdatatype cfieldname)) 1109 type (list (list datatype 'obj))) 1110 output 1111 (lambda (output) 1112 (if getter 1113 (@ " cr_ret = %s (c_obj);\n" getter) 1114 (@ " cr_ret = c_obj->%s;\n" cfieldname)))) 1115 (when settable 1116 (output-function (list (intern (format nil "%s_%s_set" 1117 cdatatype cfieldname)) 1118 'none (list (list datatype 'obj) 1119 (list type 'data))) 1120 output 1121 (lambda (output) 1122 (@ " c_obj->%s = c_data;\n" cfieldname)))))) 1123 1124(defun output-type-predicate (type output) 1125 (let* 1126 ((typage (gtk-type-info type)) 1127 (ctype (gtk-canonical-name (symbol-name type))) 1128 (rtype (gtk-hyphenate-name ctype)) 1129 (pred (gtk-type-pred typage))) 1130 (cond ((stringp pred) 1131 (setq pred (format nil "%s \(p_obj\)" pred))) 1132 ((functionp pred) 1133 (let 1134 ((temporary-output (make-string-output-stream))) 1135 (funcall pred temporary-output type "p_obj" typage nil) 1136 (setq pred (get-output-stream-string temporary-output)))) 1137 ((null pred) 1138 (setq pred "1"))) 1139 (@ "DEFUN\(\"%s-p\", F%s_p, S%s_p, \(repv p_obj\), rep_Subr1\)\n{\n" 1140 rtype ctype ctype) 1141 (@ " return \(%s\) ? Qt : Qnil;\n}\n\n" pred) 1142 (setq gtk-subrs (cons (intern (format nil "%s_p" ctype)) gtk-subrs)))) 1143 1144;; Composite type helper functions 1145 1146(defun output-helper (type output) 1147 (unless (memq type gtk-emitted-composite-helpers) 1148 (setq gtk-emitted-composite-helpers 1149 (cons type gtk-emitted-composite-helpers)) 1150 (let* 1151 ((typage (gtk-type-info type)) 1152 (pred (gtk-type-pred typage)) 1153 (decl (gtk-type-decl type typage)) 1154 (from (gtk-type-fromrep typage)) 1155 (to (gtk-type-torep typage))) 1156 1157 ;; use some hackery to get from, to, and pred functions as strings 1158 (cond ((stringp from) 1159 (setq from (concat from " \(obj\)"))) 1160 ((functionp from) 1161 (let 1162 ((temporary-output (make-string-output-stream))) 1163 (funcall from temporary-output type "obj" typage nil) 1164 (setq from (get-output-stream-string temporary-output))))) 1165 (cond ((stringp to) 1166 (setq to (format nil "%s \(*\(%s*\)mem\)" to decl))) 1167 ((functionp to) 1168 (let 1169 ((temporary-output (make-string-output-stream))) 1170 (funcall to temporary-output type 1171 (format nil "\(*\(%s*\)mem\)" decl) typage nil) 1172 (setq to (get-output-stream-string temporary-output))))) 1173 (cond ((stringp pred) 1174 (setq pred (format nil "%s \(obj\)" pred))) 1175 ((functionp pred) 1176 (let 1177 ((temporary-output (make-string-output-stream))) 1178 (funcall pred temporary-output type "obj" typage nil) 1179 (setq pred (get-output-stream-string temporary-output)))) 1180 ((null pred) 1181 (setq pred "1"))) 1182 1183 (unless (and (stringp decl) (stringp pred) (stringp from) (stringp to)) 1184 (error "Can't create composite helper for %s" type)) 1185 (@ "/* helpers for %s */\n" type) 1186 (@ "static int\n_sgtk_helper_valid_%s \(repv obj\)\n" type) 1187 (@ "\{\n return obj == Qnil || \(%s\);\n\}\n" pred) 1188 (@ "static void\n_sgtk_helper_fromrep_%s \(repv obj, void *mem\)\n" type) 1189 (@ "\{\n *\(%s*\)mem = %s;\n\}\n" decl from) 1190 (@ "static repv\n_sgtk_helper_torep_copy_%s \(void *mem\)\n" type) 1191 (@ "\{\n return %s;\n\}\n" to) 1192 ;; XXX presumably there should be a difference between the 1193 ;; XXX copy and no_copy variants!? 1194 (@ "static repv\n_sgtk_helper_torep_nocopy_%s \(void *mem\)\n" type) 1195 (@ "\{\n return %s;\n\}\n\n" to)))) 1196 1197;; Sundries 1198 1199(defun gtk-canonical-name (name) 1200 (let 1201 ((out nil) 1202 (point 0)) 1203 1204 ;; Some Classes (GtkUIManager) contain Upcase Tokens: UI 1205 (while (string-match "[A-Z]([A-Z]+)[A-Z]" name) 1206 (let ((upcase-token (substring name (match-start 1) (match-end 1)))) 1207 (setq name (string-replace upcase-token (string-downcase upcase-token) name)))) 1208 1209 (while (string-match "[A-Z]+" name point) 1210 (setq out (cons (substring name point (match-start)) out)) 1211 (unless (zerop point) 1212 (setq out (cons ?_ out))) 1213 (setq out (cons (translate-string (substring 1214 name (match-start) (match-end)) 1215 downcase-table) out)) 1216 (setq point (match-end))) 1217 (if out 1218 (progn 1219 (setq out (cons (substring name point) out)) 1220 (apply concat (nreverse out))) 1221 name))) 1222 1223(defun gtk-hyphenate-name (name) 1224 (if (string-match "_" name) 1225 (translate-string (copy-sequence name) gtk-hyphen-map) 1226 name)) 1227 1228(defun gtk-unhyphenate-name (name) 1229 (if (string-match "-" name) 1230 (translate-string (copy-sequence name) gtk-unhyphen-map) 1231 name)) 1232 1233(defun gtk-warning (fmt . args) 1234 (apply format standard-error fmt args) 1235 (write standard-error ?\n)) 1236 1237;; initialisation 1238 1239(define-type 'type "GtkType" "sgtk_rep_to_type" 1240 "sgtk_type_to_rep" "sgtk_valid_type") 1241 1242(define-type 'GValue "GValue" "sgtk_rep_to_gvalue" 1243 "sgtk_gvalue_to_rep" "sgtk_valid_gvalue") 1244 1245(define-type 'GtkArg "GtkArg" "sgtk_rep_to_arg" 1246 "sgtk_arg_to_rep" "sgtk_valid_arg") 1247 1248(define-type 'char "gchar" "sgtk_rep_to_char" 1249 "sgtk_char_to_rep" "sgtk_valid_char") 1250 1251(define-type 'bool "int" "sgtk_rep_to_bool" "sgtk_bool_to_rep" nil) 1252 1253;; XXX fix the validation functions 1254(define-type 'short "short" "sgtk_rep_to_int" "sgtk_int_to_rep" 1255 "sgtk_valid_int" '(listable . t)) 1256 1257(define-type 'ushort "gushort" "sgtk_rep_to_uint" "sgtk_uint_to_rep" 1258 "sgtk_valid_uint" '(listable . t)) 1259 1260(define-type 'int "gint" "sgtk_rep_to_int" "sgtk_int_to_rep" 1261 "sgtk_valid_int" '(listable . t)) 1262 1263(define-type 'uint "guint" "sgtk_rep_to_uint" "sgtk_uint_to_rep" 1264 "sgtk_valid_uint" '(listable . t)) 1265 1266(define-type 'GQuark "guint" "sgtk_rep_to_uint" "sgtk_uint_to_rep" 1267 "sgtk_valid_uint" '(listable . t)) 1268 1269(define-type 'long "glong" "sgtk_rep_to_long" 1270 "sgtk_long_to_rep" "sgtk_valid_long") 1271 1272(define-type 'ulong "gulong" "sgtk_rep_to_ulong" 1273 "sgtk_ulong_to_rep" "sgtk_valid_ulong") 1274 1275(define-type 'float "gfloat" "sgtk_rep_to_float" 1276 "sgtk_float_to_rep" "sgtk_valid_float") 1277 1278(define-type 'string "char*" "sgtk_rep_to_string" 1279 "sgtk_string_to_rep" "sgtk_valid_string" '(listable . t)) 1280 1281(define-type 'enum output-complex-type output-rep-to-enum 1282 output-enum-to-rep output-enum-pred) 1283 1284(define-type 'senum "char*" output-rep-to-senum 1285 output-senum-to-rep output-senum-pred) 1286 1287(define-type 'flags output-complex-type output-rep-to-flags 1288 output-flags-to-rep output-flags-pred) 1289 1290(define-type 'boxed output-complex-type output-rep-to-boxed 1291 output-boxed-to-rep output-boxed-pred '(listable . t)) 1292 1293(define-type 'GPointer "gpointer" "sgtk_rep_to_pointer" 1294 "sgtk_pointer_to_rep" "sgtk_valid_pointer") 1295 1296(define-type 'object output-complex-type output-rep-to-object 1297 output-object-to-rep output-object-pred '(listable . t)) 1298 1299(define-type 'static_string "const char*" nil 1300 "sgtk_static_string_to_rep" nil '(listable . t)) 1301 1302(define-type 'full-callback "sgtk_protshell*" output-rep-to-full-callback nil 1303 "sgtk_valid_function" (cons 'c2args output-full-callback-args) 1304 (cons 'finish output-full-callback-finish)) 1305 1306(define-type 'GClosure "GClosure*" output-rep-to-gclosure nil 1307 "sgtk_valid_function" (cons 'finish output-full-callback-finish)) 1308 1309(define-type 'file-descriptor "int" "sgtk_rep_to_fd" 1310 "sgtk_fd_to_rep" "sgtk_valid_fd") 1311 1312(define-type 'list "GList*" output-rep-to-list output-list-to-rep 1313 output-cvec-pred (cons 'finish output-list-finish)) 1314 1315(define-type 'slist "GSList*" output-rep-to-list output-list-to-rep 1316 output-cvec-pred (cons 'finish output-list-finish)) 1317 1318(define-type 'cvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep 1319 output-cvec-pred (cons 'finish output-cvec-finish) 1320 (cons 'c2args output-cvec-args)) 1321 1322(define-type 'cvecr "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep 1323 output-cvec-pred (cons 'finish output-cvec-finish) 1324 (cons 'c2args output-cvec-args)) 1325 1326(define-type 'fvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep 1327 output-cvec-pred (cons 'finish output-cvec-finish) 1328 (cons 'c2args output-cvec-args)) 1329 1330(define-type 'tvec "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep 1331 output-cvec-pred (cons 'finish output-cvec-finish) 1332 (cons 'c2args output-cvec-args)) 1333 1334(define-type 'ret "sgtk_cvec" output-rep-to-cvec output-cvec-to-rep 1335 output-cvec-pred (cons 'finish output-cvec-finish) 1336 (cons 'c2args output-cvec-args)) 1337 1338(define-type 'double "gdouble" "sgtk_rep_to_double" 1339 "sgtk_double_to_rep" "sgtk_valid_double") 1340 1341(define-type 'GdkPoint "GdkPoint" "sgtk_rep_to_point" 1342 "sgtk_point_to_rep" "sgtk_valid_point") 1343 1344(define-type 'GdkRectangle "GdkRectangle" "sgtk_rep_to_rect" 1345 "sgtk_rect_to_rep" "sgtk_valid_rect") 1346 1347(define-type 'GdkSegment "GdkSegment" "sgtk_rep_to_segment" 1348 "sgtk_segment_to_rep" "sgtk_valid_segment") 1349 1350(define-type 'SCM "repv" "" "" nil) 1351