mdw@git.distorted.org.uk Git - clg/blob - gtk/gtk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2001 Espen S. Johnsen <esj@stud.cs.uit.no>
   3 ;;
   4 ;; This library is free software; you can redistribute it and/or
   5 ;; modify it under the terms of the GNU Lesser General Public
   6 ;; License as published by the Free Software Foundation; either
   7 ;; version 2 of the License, or (at your option) any later version.
   8 ;;
   9 ;; This library is distributed in the hope that it will be useful,
  10 ;; but WITHOUT ANY WARRANTY; without even the implied warranty of
  11 ;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the GNU
  12 ;; Lesser General Public License for more details.
  13 ;;
  14 ;; You should have received a copy of the GNU Lesser General Public
  15 ;; License along with this library; if not, write to the Free Software
  16 ;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA  02111-1307  USA
  17
  18 ;; $Id: gtk.lisp,v 1.8 2002-03-24 13:28:22 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Gtk version
  24
  25 (defbinding check-version () string
  26   (required-major unsigned-int)
  27   (required-minor unsigned-int)
  28   (required-micro unsigned-int))
  29
  30 (defbinding query-version () nil
  31   (major unsigned-int :out)
  32   (minor unsigned-int :out)
  33   (micro unsigned-int :out))
  34
  35 (defun gtk-version ()
  36   (multiple-value-bind (major minor micro)
  37       (query-version)
  38     (if (zerop micro)
  39         (format nil "Gtk+ v~A.~A" major minor)
  40       (format nil "Gtk+ v~A.~A.~A" major minor micro))))
  41
  42 (defbinding get-default-language () string)
  43
  44
  45 ;;; Acccel group
  46
  47
  48 ;;; Acccel label
  49
  50 (defbinding accel-label-refetch () boolean
  51   (accel-label accel-label))
  52
  53
  54 ;;; Adjustment
  55
  56 (defbinding adjustment-changed () nil
  57   (adjustment adjustment))
  58
  59 (defbinding adjustment-value-changed () nil
  60   (adjustment adjustment))
  61
  62 (defbinding adjustment-clamp-page () nil
  63   (adjustment adjustment)
  64   (lower single-float)
  65   (upper single-float))
  66
  67
  68
  69 ;;; Alignment -- no functions
  70 ;;; Arrow -- no functions
  71
  72
  73
  74 ;;; Aspect frame
  75
  76
  77 ;;; Bin
  78
  79 (progn
  80   (declaim (optimize (ext:inhibit-warnings 3)))
  81   (defun container-remove (container child))
  82   (defun container-add (container child)))
  83
  84
  85 (defun (setf bin-child) (child bin)
  86   (when-bind (current-child (bin-child bin))
  87     (container-remove bin current-child))
  88   (container-add bin child)
  89   child)
  90
  91
  92
  93 ;;; Button box -- no functions
  94
  95
  96 ;;; Binding
  97
  98
  99
 100 ;;; Box
 101
 102 (defbinding box-pack-start () nil
 103   (box box)
 104   (child widget)
 105   (expand boolean)
 106   (fill boolean)
 107   (padding unsigned-int))
 108
 109 (defbinding box-pack-end () nil
 110   (box box)
 111   (child widget)
 112   (expand boolean)
 113   (fill boolean)
 114   (padding unsigned-int))
 115
 116 (defun box-pack (box child &key (pack :start) (expand t) (fill t) (padding 0))
 117   (if (eq pack :start)
 118       (box-pack-start box child expand fill padding)
 119     (box-pack-end box child expand fill padding)))
 120
 121 (defbinding box-reorder-child () nil
 122   (box box)
 123   (child widget)
 124   (position int))
 125
 126 (defbinding box-query-child-packing () nil
 127   (box box)
 128   (child widget)
 129   (expand boolean :out)
 130   (fill boolean :out)
 131   (padding unsigned-int :out)
 132   (pack-type pack-type :out))
 133
 134 (defbinding box-set-child-packing () nil
 135   (box box)
 136   (child widget)
 137   (expand boolean)
 138   (fill boolean)
 139   (padding unsigned-int)
 140   (pack-type pack-type))
 141
 142
 143
 144 ;;; Button
 145
 146 (defbinding button-pressed () nil
 147   (button button))
 148
 149 (defbinding button-released () nil
 150   (button button))
 151
 152 (defbinding button-clicked () nil
 153   (button button))
 154
 155 (defbinding button-enter () nil
 156   (button button))
 157
 158 (defbinding button-leave () nil
 159   (button button))
 160
 161
 162
 163 ;;; Calendar
 164
 165 (defbinding calendar-select-month () int
 166   (calendar calendar)
 167   (month unsigned-int)
 168   (year unsigned-int))
 169
 170 (defbinding calendar-select-day () nil
 171   (calendar calendar)
 172   (day unsigned-int))
 173
 174 (defbinding calendar-mark-day () int
 175   (calendar calendar)
 176   (day unsigned-int))
 177
 178 (defbinding calendar-unmark-day () int
 179   (calendar calendar)
 180   (day unsigned-int))
 181
 182 (defbinding calendar-clear-marks () nil
 183   (calendar calendar))
 184
 185 (defbinding calendar-display-options () nil
 186   (calendar calendar)
 187   (options calendar-display-options))
 188
 189 (defbinding (calendar-date "gtk_calendar_get_date") () nil
 190   (calendar calendar)
 191   (year unsigned-int :out)
 192   (month unsigned-int :out)
 193   (day unsigned-int :out))
 194
 195 (defbinding calendar-freeze () nil
 196   (calendar calendar))
 197
 198 (defbinding calendar-thaw () nil
 199   (calendar calendar))
 200
 201
 202
 203 ;;; Cell editable
 204
 205
 206
 207 ;;; Cell renderer
 208
 209
 210
 211 ;;; Cell renderer pixbuf -- no functions
 212
 213
 214
 215 ;;; Cell renderer text
 216
 217
 218
 219 ;;; Cell renderer toggle -- no functions
 220
 221
 222
 223 ;;; Check button -- no functions
 224
 225
 226
 227 ;;; Check menu item
 228
 229 (defbinding check-menu-item-toggled () nil
 230   (check-menu-item check-menu-item))
 231
 232
 233
 234 ;;; Clipboard
 235
 236
 237 ;;; Color selection
 238
 239 (defbinding (color-selection-is-adjusting-p
 240              "gtk_color_selection_is_adjusting") () boolean
 241   (colorsel color-selection))
 242
 243
 244
 245 ;;; Color selection dialog -- no functions
 246
 247
 248
 249 ;;; Combo
 250
 251 (defbinding combo-set-value-in-list () nil
 252   (combo combo)
 253   (value boolean)
 254   (ok-if-empty boolean))
 255
 256 (defbinding combo-set-item-string () nil
 257   (combo combo)
 258   (item item)
 259   (item-value string))
 260
 261 (defbinding combo-set-popdown-strings () nil
 262   (combo combo)
 263   (strings (glist string)))
 264
 265 (defbinding combo-disable-activate () nil
 266   (combo combo))
 267
 268
 269
 270 ;;; Dialog
 271
 272 (defmethod initialize-instance ((dialog dialog) &rest initargs)
 273   (apply #'call-next-method dialog (plist-remove initargs :child))
 274   (dolist (button-definition (get-all initargs :button))
 275     (apply #'dialog-add-button dialog button-definition))
 276   (dolist (child (get-all initargs :child))
 277     (apply #'dialog-add-child dialog (mklist child))))
 278
 279
 280 (defvar %*response-id-key* (gensym))
 281
 282 (defun %dialog-find-response-id-num (dialog response-id create-p)
 283   (or
 284    (cadr (assoc response-id (rest (type-expand-1 'response-type))))
 285    (let* ((response-ids (object-data dialog %*response-id-key*))
 286           (response-id-num (position response-id response-ids)))
 287     (cond
 288      (response-id-num)
 289      (create-p
 290       (cond
 291        (response-ids
 292         (setf (cdr (last response-ids)) (list response-id))
 293         (1- (length response-ids)))
 294        (t
 295         (setf (object-data dialog %*response-id-key*) (list response-id))
 296         0)))
 297      (t
 298       (error "Invalid response id: ~A" response-id))))))
 299
 300 (defun %dialog-find-response-id (dialog response-id-num)
 301   (if (< response-id-num 0)
 302       (car
 303        (rassoc
 304         (list response-id-num)
 305         (rest (type-expand-1 'response-type)) :test #'equalp))
 306     (nth response-id-num (object-data dialog %*response-id-key*))))
 307
 308
 309 (defmethod signal-connect ((dialog dialog) signal function &key object)
 310   (case signal
 311     (response
 312      #'(lambda (dialog response-id-num)
 313          (let ((response-id (%dialog-find-response-id dialog response-id-num)))
 314            (cond
 315             ((eq object t)  (funcall function dialog response-id))
 316             (object (funcall function object response-id))
 317             (t (funcall function response-id))))))
 318     (t
 319      (call-next-method))))
 320
 321
 322 (defbinding dialog-response (dialog response-id) nil
 323   (dialog dialog)
 324   ((%dialog-find-response-id-num dialog response-id nil) int))
 325
 326 (defbinding %dialog-set-default-response () nil
 327   (dialog dialog)
 328   (response-id-num int))
 329
 330 (defun dialog-set-default-response (dialog response-id)
 331   (%dialog-set-default-response
 332    dialog (%dialog-find-response-id-num dialog response-id nil)))
 333
 334 (defbinding dialog-set-response-sensitive (dialog response-id sensitive) nil
 335   (dialog dialog)
 336   ((%dialog-find-response-id-num dialog response-id nil) int)
 337   (sensitive boolean))
 338
 339
 340 (defbinding %dialog-add-button () button
 341   (dialog dialog)
 342   (text string)
 343   (response-id-num int))
 344
 345 (defun dialog-add-button (dialog label &optional response-id default-p)
 346   (let* ((response-id-num
 347           (if response-id
 348               (%dialog-find-response-id-num dialog response-id t)
 349             (length (object-data dialog %*response-id-key*))))
 350          (button (%dialog-add-button dialog label response-id-num)))
 351     (unless response-id
 352       (%dialog-find-response-id-num dialog button t))
 353     (when default-p
 354       (%dialog-set-default-response dialog response-id-num))
 355     button))
 356
 357
 358 (defbinding %dialog-add-action-widget () button
 359   (dialog dialog)
 360   (action-widget widget)
 361   (response-id-num int))
 362
 363 (defun dialog-add-action-widget (dialog widget &optional (response-id widget)
 364                                  default-p)
 365   (let ((response-id-num (%dialog-find-response-id-num dialog response-id t)))
 366     (%dialog-add-action-widget dialog widget response-id-num)
 367     (when default-p
 368       (%dialog-set-default-response dialog response-id-num))
 369     widget))
 370
 371
 372 (defun dialog-add-child (dialog child &rest args)
 373   (apply #'container-add (slot-value dialog 'vbox) child args))
 374
 375 (defmethod container-children ((dialog dialog))
 376   (container-children (dialog-vbox dialog)))
 377
 378 (defmethod (setf container-children) (children (dialog dialog))
 379   (setf (container-children (dialog-vbox dialog)) children))
 380
 381
 382
 383 ;;; Drawing area -- no functions
 384
 385
 386
 387
 388
 389
 390
 391 ;;; Toggle button
 392
 393 (defbinding toggle-button-toggled () nil
 394   (toggle-button toggle-button))
 395
 396
 397 ;;; Label
 398
 399 (defbinding label-select-region () nil
 400   (label label)
 401   (start int)
 402   (end int))
 403
 404
 405
 406
 407 ;;; Radio button
 408
 409 (defbinding %radio-button-get-group () pointer
 410   (radio-button radio-button))
 411
 412 (defbinding %radio-button-set-group () nil
 413   (radio-button radio-button)
 414   (group pointer))
 415
 416 (defun radio-button-add-to-group (button1 button2)
 417   "Add BUTTON1 to the group which BUTTON2 belongs to."
 418   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 419
 420
 421 (defmethod initialize-instance ((button radio-button)
 422                                 &rest initargs &key group-with)
 423   (declare (ignore initargs))
 424   (call-next-method)
 425   (when group-with
 426     (radio-button-add-to-group item group-with)))
 427
 428
 429 ;;; Option menu
 430
 431 (defbinding %option-menu-set-menu () nil
 432   (option-menu option-menu)
 433   (menu widget))
 434
 435 (defbinding %option-menu-remove-menu () nil
 436   (option-menu option-menu))
 437
 438 (defun (setf option-menu-menu) (menu option-menu)
 439   (if (not menu)
 440       (%option-menu-remove-menu option-menu)
 441     (%option-menu-set-menu option-menu menu))
 442   menu)
 443
 444
 445
 446 ;;; Item
 447
 448 (defbinding item-select () nil
 449   (item item))
 450
 451 (defbinding item-deselect () nil
 452   (item item))
 453
 454 (defbinding item-toggle () nil
 455   (item item))
 456
 457
 458
 459 ;;; Menu item
 460
 461 (defun (setf menu-item-label) (label menu-item)
 462   (make-instance 'accel-label
 463    :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
 464    :visible t :parent menu-item)
 465   label)
 466
 467 (defbinding %menu-item-set-submenu () nil
 468   (menu-item menu-item)
 469   (submenu menu))
 470
 471 (defbinding %menu-item-remove-submenu () nil
 472   (menu-item menu-item))
 473
 474 (defun (setf menu-item-submenu) (submenu menu-item)
 475   (if (not submenu)
 476       (%menu-item-remove-submenu menu-item)
 477     (%menu-item-set-submenu menu-item submenu))
 478   submenu)
 479
 480 (defbinding menu-item-select () nil
 481   (menu-item menu-item))
 482
 483 (defbinding menu-item-deselect () nil
 484   (menu-item menu-item))
 485
 486 (defbinding menu-item-activate () nil
 487   (menu-item menu-item))
 488
 489
 490
 491 ;;; Radio menu item
 492
 493 (defbinding %radio-menu-item-get-group () pointer
 494   (radio-menu-item radio-menu-item))
 495
 496 (defbinding %radio-menu-item-set-group () nil
 497   (radio-menu-item radio-menu-item)
 498   (group pointer))
 499
 500 (defun radio-menu-item-add-to-group (item1 item2)
 501   "Add ITEM1 to the group which ITEM2 belongs to."
 502   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 503
 504 (defmethod initialize-instance ((item radio-menu-item)
 505                                 &rest initargs &key group-with)
 506   (declare (ignore initargs))
 507   (call-next-method)
 508   (when group-with
 509     (radio-menu-item-add-to-group item group-with)))
 510
 511
 512
 513 ;;; Window
 514
 515 (defbinding %window-set-wmclass () nil
 516   (window window)
 517   (wmclass-name string)
 518   (wmclass-class string))
 519
 520 (defun (setf window-wmclass) (wmclass window)
 521   (%window-set-wmclass window (svref wmclass 0) (svref wmclass 1))
 522   (values (svref wmclass 0) (svref wmclass 1)))
 523
 524 ;; gtkglue.c
 525 (defbinding window-wmclass () nil
 526   (window window)
 527   (wmclass-name string :out)
 528   (wmclass-class string :out))
 529
 530 (defbinding window-add-accel-group () nil
 531   (window window)
 532   (accel-group accel-group))
 533
 534 (defbinding window-remove-accel-group () nil
 535   (window window)
 536   (accel-group accel-group))
 537
 538 (defbinding window-activate-focus () int
 539   (window window))
 540
 541 (defbinding window-activate-default () int
 542   (window window))
 543
 544 (defbinding window-set-transient-for () nil
 545   (window window)
 546   (parent window))
 547
 548 ;(defbinding window-set-geometry-hints)
 549
 550
 551
 552 ;;; File selection
 553
 554 (defbinding file-selection-complete () nil
 555   (file-selection file-selection)
 556   (pattern string))
 557
 558
 559
 560 ;;; Scrolled window
 561
 562 (defun (setf scrolled-window-scrollbar-policy) (policy window)
 563   (setf (scrolled-window-hscrollbar-policy window) policy)
 564   (setf (scrolled-window-vscrollbar-policy window) policy))
 565
 566 (defbinding scrolled-window-add-with-viewport () nil
 567    (scrolled-window scrolled-window)
 568    (child widget))
 569
 570
 571
 572
 573
 574
 575
 576
 577
 578
 579
 580
 581
 582
 583 ;;; Statusbar
 584
 585 (defbinding (statusbar-context-id "gtk_statusbar_get_context_id")
 586     () unsigned-int
 587   (statusbar statusbar)
 588   (context-description string))
 589
 590 (defbinding statusbar-push () unsigned-int
 591   (statusbar statusbar)
 592   (context-id unsigned-int)
 593   (text string))
 594
 595 (defbinding statusbar-pop () nil
 596   (statusbar statusbar)
 597   (context-id unsigned-int))
 598
 599 (defbinding statusbar-remove () nil
 600   (statusbar statusbar)
 601   (context-id unsigned-int)
 602   (message-id unsigned-int))
 603
 604
 605
 606 ;;; Fixed
 607
 608 (defbinding fixed-put () nil
 609   (fixed fixed)
 610   (widget widget)
 611   (x (signed 16))
 612   (y (signed 16)))
 613
 614 (defbinding fixed-move () nil
 615   (fixed fixed)
 616   (widget widget)
 617   (x (signed 16))
 618   (y (signed 16)))
 619
 620
 621
 622 ;;; Notebook
 623
 624 (defbinding (notebook-insert-page "gtk_notebook_insert_page_menu")
 625     (notebook position child tab-label &optional menu-label) nil
 626   (notebook notebook)
 627   (child widget)
 628   ((if (stringp tab-label)
 629        (label-new tab-label)
 630      tab-label) widget)
 631   ((if (stringp menu-label)
 632        (label-new menu-label)
 633      menu-label) (or null widget))
 634   (position int))
 635
 636 (defun notebook-append-page (notebook child tab-label &optional menu-label)
 637   (notebook-insert-page notebook -1 child tab-label menu-label))
 638
 639 (defun notebook-prepend-page (notebook child tab-label &optional menu-label)
 640   (notebook-insert-page notebook 0 child tab-label menu-label))
 641
 642 (defbinding notebook-remove-page () nil
 643   (notebook notebook)
 644   (page-num int))
 645
 646 ; (defun notebook-current-page-num (notebook)
 647 ;   (let ((page-num (notebook-current-page notebook)))
 648 ;     (if (= page-num -1)
 649 ;       nil
 650 ;       page-num)))
 651
 652 (defbinding (notebook-nth-page-child "gtk_notebook_get_nth_page") () widget
 653   (notebook notebook)
 654   (page-num int))
 655
 656 (defun notebook-page-child (notebook)
 657   (notebook-nth-page-child notebook (notebook-page notebook)))
 658
 659 (defbinding %notebook-page-num () int
 660   (notebook notebook)
 661   (child widget))
 662
 663 (defun notebook-child-num (notebook child)
 664   (let ((page-num (%notebook-page-num notebook child)))
 665     (if (= page-num -1)
 666         nil
 667       page-num)))
 668
 669 (defbinding notebook-next-page () nil
 670   (notebook notebook))
 671
 672 (defbinding notebook-prev-page () nil
 673   (notebook notebook))
 674
 675 (defbinding notebook-popup-enable () nil
 676   (notebook notebook))
 677
 678 (defbinding notebook-popup-disable () nil
 679   (notebook notebook))
 680
 681 ; (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
 682 ;     (notebook ref) widget
 683 ;   (notebook notebook)
 684 ;   ((if (typep ref 'widget)
 685 ;        ref
 686 ;      (notebook-nth-page-child notebook ref))
 687 ;    widget))
 688
 689 ; (defbinding %notebook-set-tab-label () nil
 690 ;   (notebook notebook)
 691 ;   (reference widget)
 692 ;   (tab-label widget))
 693
 694 ; (defun (setf notebook-tab-label) (tab-label notebook reference)
 695 ;   (let ((tab-label-widget (if (stringp tab-label)
 696 ;                             (label-new tab-label)
 697 ;                           tab-label)))
 698 ;     (%notebook-set-tab-label
 699 ;      notebook
 700 ;      (if (typep reference 'widget)
 701 ;        reference
 702 ;        (notebook-nth-page-child notebook reference))
 703 ;      tab-label-widget)
 704 ;     tab-label-widget))
 705
 706 ; (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
 707 ;     (notebook ref) widget
 708 ;   (notebook notebook)
 709 ;   ((if (typep ref 'widget)
 710 ;        ref
 711 ;      (notebook-nth-page-child notebook ref))
 712 ;    widget))
 713
 714 ; (defbinding %notebook-set-menu-label () nil
 715 ;   (notebook notebook)
 716 ;   (reference widget)
 717 ;   (menu-label widget))
 718
 719 ; (defun (setf notebook-menu-label) (menu-label notebook reference)
 720 ;   (let ((menu-label-widget (if (stringp menu-label)
 721 ;                             (label-new menu-label)
 722 ;                           menu-label)))
 723 ;     (%notebook-set-menu-label
 724 ;      notebook
 725 ;      (if (typep reference 'widget)
 726 ;        reference
 727 ;        (notebook-nth-page-child notebook reference))
 728 ;      menu-label-widget)
 729 ;     menu-label-widget))
 730
 731 (defbinding notebook-query-tab-label-packing (notebook ref) nil
 732   (notebook notebook)
 733   ((if (typep ref 'widget)
 734        ref
 735      (notebook-nth-page-child notebook ref))
 736    widget)
 737   (expand boolean :out)
 738   (fill boolean :out)
 739   (pack-type pack-type :out))
 740
 741 (defbinding
 742     notebook-set-tab-label-packing (notebook ref expand fill pack-type) nil
 743   (notebook notebook)
 744   ((if (typep ref 'widget)
 745        ref
 746      (notebook-nth-page-child notebook ref))
 747    widget)
 748   (expand boolean)
 749   (fill boolean)
 750   (pack-type pack-type))
 751
 752 (defbinding notebook-reorder-child () nil
 753   (notebook notebook)
 754   (child widget)
 755   (position int))
 756
 757
 758
 759 ;;; Paned
 760
 761 (defbinding paned-pack1 () nil
 762   (paned paned)
 763   (child widget)
 764   (resize boolean)
 765   (shrink boolean))
 766
 767 (defbinding paned-pack2 () nil
 768   (paned paned)
 769   (child widget)
 770   (resize boolean)
 771   (shrink boolean))
 772
 773 ;; gtkglue.c
 774 (defbinding paned-child1 () widget
 775   (paned paned)
 776   (resize boolean :out)
 777   (shrink boolean :out))
 778
 779 ;; gtkglue.c
 780 (defbinding paned-child2 () widget
 781   (paned paned)
 782   (resize boolean :out)
 783   (shrink boolean :out))
 784
 785 (defun (setf paned-child1) (child paned)
 786   (paned-pack1 paned child nil t))
 787
 788 (defun (setf paned-child2) (child paned)
 789   (paned-pack2 paned child t t))
 790
 791
 792
 793 ;;; Layout
 794
 795 (defbinding layout-put () nil
 796   (layout layout)
 797   (widget widget)
 798   (x int)
 799   (y int))
 800
 801 (defbinding layout-move () nil
 802   (layout layout)
 803   (widget widget)
 804   (x int)
 805   (y int))
 806
 807 (defbinding layout-set-size () nil
 808   (layout layout)
 809   (width int)
 810   (height int))
 811
 812 (defbinding layout-get-size () nil
 813   (layout layout)
 814   (width int :out)
 815   (height int :out))
 816
 817
 818
 819 ;;; Menu shell
 820
 821 (defbinding menu-shell-insert () nil
 822   (menu-shell menu-shell)
 823   (menu-item menu-item)
 824   (position int))
 825
 826 (defun menu-shell-append (menu-shell menu-item)
 827   (menu-shell-insert menu-shell menu-item -1))
 828
 829 (defun menu-shell-prepend (menu-shell menu-item)
 830   (menu-shell-insert menu-shell menu-item 0))
 831
 832 (defbinding menu-shell-deactivate () nil
 833   (menu-shell menu-shell))
 834
 835 (defbinding menu-shell-select-item () nil
 836   (menu-shell menu-shell)
 837   (menu-item menu-item))
 838
 839 (defbinding menu-shell-deselect () nil
 840   (menu-shell menu-shell))
 841
 842 (defbinding menu-shell-activate-item () nil
 843   (menu-shell menu-shell)
 844   (menu-item menu-item)
 845   (fore-deactivate boolean))
 846
 847
 848
 849 ; ;;; Menu bar
 850
 851 ; (defbinding menu-bar-insert () nil
 852 ;   (menu-bar menu-bar)
 853 ;   (menu menu)
 854 ;   (position int))
 855
 856 ; (defun menu-bar-append (menu-bar menu)
 857 ;   (menu-bar-insert menu-bar menu -1))
 858
 859 ; (defun menu-bar-prepend (menu-bar menu)
 860 ;   (menu-bar-insert menu-bar menu 0))
 861
 862
 863
 864 ; ;;; Menu
 865
 866 ;(defun menu-popup ...)
 867
 868 (defbinding menu-reposition () nil
 869   (menu menu))
 870
 871 (defbinding menu-popdown () nil
 872   (menu menu))
 873
 874 (defbinding %menu-set-active () nil
 875   (menu menu)
 876   (index unsigned-int))
 877
 878 (defun (setf menu-active) (menu index)
 879   (%menu-set-active menu index))
 880
 881 (defbinding menu-reorder-child () nil
 882   (menu menu)
 883   (menu-item menu-item)
 884   (position int))
 885
 886
 887 ;;; Table
 888
 889 (defbinding table-resize () nil
 890   (table table)
 891   (rows unsigned-int)
 892   (columns unsigned-int))
 893
 894 (defbinding table-attach (table child left right top bottom
 895                                &key (x-options '(:expand :fill))
 896                                     (y-options '(:expand :fill))
 897                                     (x-padding 0) (y-padding 0)) nil
 898   (table table)
 899   (child widget)
 900   (left unsigned-int)
 901   (right unsigned-int)
 902   (top unsigned-int)
 903   (bottom unsigned-int)
 904   (x-options attach-options)
 905   (y-options attach-options)
 906   (x-padding unsigned-int)
 907   (y-padding unsigned-int))
 908
 909
 910 (defbinding %table-set-row-spacing () nil
 911   (table table)
 912   (row unsigned-int)
 913   (spacing unsigned-int))
 914
 915 (defbinding %table-set-row-spacings () nil
 916   (table table)
 917   (spacing unsigned-int))
 918
 919 (defun (setf table-row-spacing) (spacing table &optional row)
 920   (if row
 921       (%table-set-row-spacing table row spacing)
 922     (%table-set-row-spacings table spacing))
 923   spacing)
 924
 925 (defbinding %table-get-row-spacing () unsigned-int
 926   (table table)
 927   (row unsigned-int))
 928
 929 (defbinding %table-get-default-row-spacing () unsigned-int
 930   (table table))
 931
 932 (defun table-row-spacing (table &optional row)
 933   (if row
 934       (%table-get-row-spacing table row)
 935     (%table-get-default-row-spacing table)))
 936
 937
 938 (defbinding %table-set-col-spacing () nil
 939   (table table)
 940   (col unsigned-int)
 941   (spacing unsigned-int))
 942
 943 (defbinding %table-set-col-spacings () nil
 944   (table table)
 945   (spacing unsigned-int))
 946
 947 (defun (setf table-col-spacing) (spacing table &optional col)
 948   (if col
 949       (%table-set-col-spacing table col spacing)
 950     (%table-set-col-spacings table spacing))
 951   spacing)
 952
 953 (defbinding %table-get-col-spacing () unsigned-int
 954   (table table)
 955   (col unsigned-int))
 956
 957 (defbinding %table-get-default-col-spacing () unsigned-int
 958   (table table))
 959
 960 (defun table-col-spacing (table &optional col)
 961   (if col
 962       (%table-get-col-spacing table col)
 963     (%table-get-default-col-spacing table)))
 964
 965
 966
 967 ;;; Toolbar
 968
 969 ;; gtkglue.c
 970 (defbinding toolbar-num-children () int
 971   (toolbar toolbar))
 972
 973 (defun %toolbar-position-num (toolbar position)
 974   (case position
 975     (:prepend 0)
 976     (:append (toolbar-num-children toolbar))
 977     (t
 978      (assert (and (>= position 0) (< position (toolbar-num-children toolbar))))
 979      position)))
 980
 981 (defbinding %toolbar-insert-element () widget
 982   (toolbar toolbar)
 983   (type toolbar-child-type)
 984   (widget (or null widget))
 985   (text string)
 986   (tooltip-text string)
 987   (tooltip-private-text string)
 988   (icon (or null widget))
 989   (nil null)
 990   (nil null)
 991   (position int))
 992
 993 (defun toolbar-insert-element (toolbar position
 994                                &key tooltip-text tooltip-private-text
 995                                type widget icon text callback)
 996   (let* ((icon-widget (typecase icon
 997                        ((or null widget) icon)
 998                        (t (pixmap-new icon))))
 999          (toolbar-child
1000           (%toolbar-insert-element
1001            toolbar (or type (and widget :widget) :button)
1002            widget text tooltip-text tooltip-private-text icon-widget
1003            (%toolbar-position-num toolbar position))))
1004     (when callback
1005       (signal-connect toolbar-child 'clicked callback))
1006     toolbar-child))
1007
1008 (defun toolbar-append-element (toolbar &key tooltip-text tooltip-private-text
1009                                type widget icon text callback)
1010   (toolbar-insert-element
1011    toolbar :append :type type :widget widget :icon icon :text text
1012    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
1013    :callback callback))
1014
1015 (defun toolbar-prepend-element (toolbar &key tooltip-text tooltip-private-text
1016                                 type widget icon text callback)
1017   (toolbar-insert-element
1018    toolbar :prepend :type type :widget widget :icon icon :text text
1019    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
1020    :callback callback))
1021
1022 (defun toolbar-insert-space (toolbar position)
1023   (toolbar-insert-element toolbar position :type :space))
1024
1025 (defun toolbar-append-space (toolbar)
1026   (toolbar-insert-space toolbar :append))
1027
1028 (defun toolbar-prepend-space (toolbar)
1029   (toolbar-insert-space toolbar :prepend))
1030
1031 (defun toolbar-insert-widget (toolbar widget position &key tooltip-text
1032                               tooltip-private-text callback)
1033   (toolbar-insert-element
1034    toolbar position :widget widget :tooltip-text tooltip-text
1035    :tooltip-private-text tooltip-private-text :callback callback))
1036
1037 (defun toolbar-append-widget (toolbar widget &key tooltip-text
1038                               tooltip-private-text callback)
1039   (toolbar-insert-widget
1040    toolbar widget :append :tooltip-text tooltip-text
1041    :tooltip-private-text tooltip-private-text :callback callback))
1042
1043 (defun toolbar-prepend-widget (toolbar widget &key tooltip-text
1044                                tooltip-private-text callback)
1045   (toolbar-insert-widget
1046    toolbar widget :prepend :tooltip-text tooltip-text
1047    :tooltip-private-text tooltip-private-text :callback callback))
1048
1049 (defun toolbar-insert-item (toolbar text icon position &key tooltip-text
1050                             tooltip-private-text callback)
1051   (toolbar-insert-element
1052    toolbar position :text text :icon icon :callback callback
1053    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1054
1055 (defun toolbar-append-item (toolbar text icon &key tooltip-text
1056                             tooltip-private-text callback)
1057   (toolbar-insert-item
1058    toolbar text icon :append :callback callback
1059    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1060
1061
1062 (defun toolbar-prepend-item (toolbar text icon &key tooltip-text
1063                              tooltip-private-text callback)
1064   (toolbar-insert-item
1065    toolbar text icon :prepend :callback callback
1066    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1067
1068 (defun toolbar-enable-tooltips (toolbar)
1069   (setf (toolbar-tooltips-p toolbar) t))
1070
1071 (defun toolbar-disable-tooltips (toolbar)
1072   (setf (toolbar-tooltips-p toolbar) nil))
1073
1074
1075
1076
1077
1078
1079
1080
1081 ;;; Editable
1082 #|
1083 (defbinding editable-select-region (editable &optional (start 0) end) nil
1084   (editable editable)
1085   (start int)
1086   ((or end -1) int))
1087
1088 (defbinding editable-insert-text
1089     (editable text &optional (position 0)) nil
1090   (editable editable)
1091   (text string)
1092   ((length text) int)
1093   ((or position -1) int :in-out))
1094
1095 (defun editable-append-text (editable text)
1096   (editable-insert-text editable text nil))
1097
1098 (defun editable-prepend-text (editable text)
1099   (editable-insert-text editable text 0))
1100
1101 (defbinding editable-delete-text (editable &optional (start 0) end) nil
1102   (editable editable)
1103   (start int)
1104   ((or end -1) int))
1105
1106 (defbinding (editable-text "gtk_editable_get_chars")
1107     (editable &optional (start 0) end) string
1108   (editable editable)
1109   (start int)
1110   ((or end -1) int))
1111
1112 (defun (setf editable-text) (text editable)
1113   (if text
1114       (editable-delete-text
1115        editable
1116        (editable-insert-text editable text))
1117     (editable-delete-text editable))
1118   text)
1119
1120 (defbinding editable-cut-clipboard () nil
1121   (editable editable))
1122
1123 (defbinding editable-copy-clipboard () nil
1124   (editable editable))
1125
1126 (defbinding editable-paste-clipboard () nil
1127   (editable editable))
1128
1129 ; (defbinding editable-claim-selection () nil
1130 ;   (editable editable)
1131 ;   (claim boolean)
1132 ;   (time unsigned-int))
1133
1134 (defbinding editable-delete-selection () nil
1135   (editable editable))
1136
1137 ; (defbinding editable-changed () nil
1138 ;   (editable editable))
1139 |#
1140
1141
1142 ;;; Spin button
1143
1144 (defun spin-button-value-as-int (spin-button)
1145   (round (spin-button-value spin-button)))
1146
1147 (defbinding spin-button-spin () nil
1148   (spin-button spin-button)
1149   (direction spin-type)
1150   (increment single-float))
1151
1152 (defbinding spin-button-update () nil
1153   (spin-button spin-button))
1154
1155
1156
1157 ; ;;; Ruler
1158
1159 (defbinding ruler-set-range () nil
1160   (ruler ruler)
1161   (lower single-float)
1162   (upper single-float)
1163   (position single-float)
1164   (max-size single-float))
1165
1166 (defbinding ruler-draw-ticks () nil
1167   (ruler ruler))
1168
1169 (defbinding ruler-draw-pos () nil
1170   (ruler ruler))
1171
1172
1173
1174 ;;; Range
1175 #|
1176 (defbinding range-draw-background () nil
1177   (range range))
1178
1179 (defbinding range-clear-background () nil
1180   (range range))
1181
1182 (defbinding range-draw-trough () nil
1183   (range range))
1184
1185 (defbinding range-draw-slider () nil
1186   (range range))
1187
1188 (defbinding range-draw-step-forw () nil
1189   (range range))
1190
1191 (defbinding range-slider-update () nil
1192   (range range))
1193
1194 (defbinding range-trough-click () int
1195   (range range)
1196   (x int)
1197   (y int)
1198   (jump-perc single-float :out))
1199
1200 (defbinding range-default-hslider-update () nil
1201   (range range))
1202
1203 (defbinding range-default-vslider-update () nil
1204   (range range))
1205
1206 (defbinding range-default-htrough-click () int
1207   (range range)
1208   (x int)
1209   (y int)
1210   (jump-perc single-float :out))
1211
1212 (defbinding range-default-vtrough-click () int
1213   (range range)
1214   (x int)
1215   (y int)
1216   (jump-perc single-float :out))
1217
1218 (defbinding range-default-hmotion () int
1219   (range range)
1220   (x-delta int)
1221   (y-delta int))
1222
1223 (defbinding range-default-vmotion () int
1224   (range range)
1225   (x-delta int)
1226   (y-delta int))
1227 |#
1228
1229
1230 ;;; Scale
1231
1232 ; (defbinding scale-draw-value () nil
1233 ;   (scale scale))
1234
1235
1236
1237 ;;; Progress bar
1238
1239 (defbinding progress-bar-pulse () nil
1240   (progress-bar progress-bar))
1241
1242
1243
1244
1245
1246 ;;; Tooltips
1247
1248 (defbinding tooltips-enable () nil
1249   (tooltips tooltips))
1250
1251 (defbinding tooltips-disable () nil
1252   (tooltips tooltips))
1253
1254 (defun (setf tooltips-enabled-p) (enable tooltips)
1255   (if enable
1256       (tooltips-enable tooltips)
1257     (tooltips-disable tooltips)))
1258
1259 (defbinding tooltips-set-tip () nil
1260   (tooltips tooltips)
1261   (widget widget)
1262   (tip-text string)
1263   (tip-private string))
1264
1265 (defbinding tooltips-force-window () nil
1266   (tooltips tooltips))
1267
1268
1269
1270 ;;; Rc
1271
1272 (defbinding rc-add-default-file (filename) nil
1273   ((namestring (truename filename)) string))
1274
1275 (defbinding rc-parse (filename) nil
1276   ((namestring (truename filename)) string))
1277
1278 (defbinding rc-parse-string () nil
1279   (rc-string string))
1280
1281 (defbinding rc-reparse-all () nil)
1282
1283 (defbinding rc-get-style () style
1284   (widget widget))
1285
1286
1287
1288 ;;; Accelerator Groups
1289 #|
1290 (defbinding accel-group-get-default () accel-group)
1291
1292 (deftype-method alien-ref accel-group (type-spec)
1293   (declare (ignore type-spec))
1294   '%accel-group-ref)
1295
1296 (deftype-method alien-unref accel-group (type-spec)
1297   (declare (ignore type-spec))
1298   '%accel-group-unref)
1299
1300 (defbinding %accel-group-ref () accel-group
1301   (accel-group (or accel-group pointer)))
1302
1303 (defbinding %accel-group-unref () nil
1304   (accel-group (or accel-group pointer)))
1305
1306 (defbinding accel-group-activate (accel-group key modifiers) boolean
1307   (accel-group accel-group)
1308   ((gdk:keyval-from-name key) unsigned-int)
1309   (modifiers gdk:modifier-type))
1310
1311 (defbinding accel-groups-activate (object key modifiers) boolean
1312   (object object)
1313   ((gdk:keyval-from-name key) unsigned-int)
1314   (modifiers gdk:modifier-type))
1315
1316 (defbinding accel-group-attach () nil
1317   (accel-group accel-group)
1318   (object object))
1319
1320 (defbinding accel-group-detach () nil
1321   (accel-group accel-group)
1322   (object object))
1323
1324 (defbinding accel-group-lock () nil
1325   (accel-group accel-group))
1326
1327 (defbinding accel-group-unlock () nil
1328   (accel-group accel-group))
1329
1330
1331 ;;; Accelerator Groups Entries
1332
1333 (defbinding accel-group-get-entry (accel-group key modifiers) accel-entry
1334   (accel-group accel-group)
1335   ((gdk:keyval-from-name key) unsigned-int)
1336   (modifiers gdk:modifier-type))
1337
1338 (defbinding accel-group-lock-entry (accel-group key modifiers) nil
1339   (accel-group accel-group)
1340   ((gdk:keyval-from-name key) unsigned-int)
1341   (modifiers gdk:modifier-type))
1342
1343 (defbinding accel-group-unlock-entry (accel-group key modifiers) nil
1344   (accel-group accel-group)
1345   ((gdk:keyval-from-name key) unsigned-int)
1346   (modifiers gdk:modifier-type))
1347
1348 (defbinding accel-group-add
1349     (accel-group key modifiers flags object signal) nil
1350   (accel-group accel-group)
1351   ((gdk:keyval-from-name key) unsigned-int)
1352   (modifiers gdk:modifier-type)
1353   (flags accel-flags)
1354   (object object)
1355   ((name-to-string signal) string))
1356
1357 (defbinding accel-group-add (accel-group key modifiers object) nil
1358   (accel-group accel-group)
1359   ((gdk:keyval-from-name key) unsigned-int)
1360   (modifiers gdk:modifier-type)
1361   (object object))
1362
1363
1364 ;;; Accelerator Signals
1365
1366 (defbinding accel-group-handle-add
1367     (object signal-id accel-group key modifiers flags) nil
1368   (object object)
1369   (signal-id unsigned-int)
1370   (accel-group accel-group)
1371   ((gdk:keyval-from-name key) unsigned-int)
1372   (modifiers gdk:modifier-type)
1373   (flags accel-flags))
1374
1375 (defbinding accel-group-handle-remove
1376     (object accel-group key modifiers) nil
1377   (object object)
1378   (accel-group accel-group)
1379   ((gdk:keyval-from-name key) unsigned-int)
1380   (modifiers gdk:modifier-type))
1381 |#