chiark - git - mdw - clg/blob - gtk/gtk.lisp

   1 ;; Common Lisp bindings for GTK+ v2.0
   2 ;; Copyright (C) 1999-2000 Espen S. Johnsen <espejohn@online.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.3 2000-10-05 17:30:07 espen Exp $
  19
  20
  21 (in-package "GTK")
  22
  23 ;;; Gtk version
  24
  25 (define-foreign check-version () string
  26   (required-major unsigned-int)
  27   (required-minor unsigned-int)
  28   (required-micro unsigned-int))
  29
  30 (define-foreign 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
  43
  44 ;;; Label
  45
  46 (define-foreign label-new () label
  47   (text string))
  48
  49 (define-foreign label-parse-uline () unsigned-int
  50   (label label)
  51   (string string))
  52
  53
  54
  55 ;;; Acccel label
  56
  57 (define-foreign accel-label-new () accel-label
  58   (text string))
  59
  60 (define-foreign accel-label-refetch () boolean
  61   (accel-label accel-label))
  62
  63
  64
  65 ;;; Tips query
  66
  67 (define-foreign tips-query-new () tips-query)
  68
  69 (define-foreign tips-query-start-query () nil
  70   (tips-query tips-query))
  71
  72 (define-foreign tips-query-stop-query () nil
  73   (tips-query tips-query))
  74
  75
  76
  77 ;;; Arrow
  78
  79 (define-foreign arrow-new () arrow
  80   (arrow-type arrow-type)
  81   (shadow-type shadow-type))
  82
  83
  84
  85 ;;; Pixmap
  86
  87 (defmethod initialize-instance ((pixmap pixmap) &rest initargs
  88                                 &key source mask)
  89   (declare (ignore initargs))
  90   (call-next-method)
  91   (if (typep source 'gdk:pixmap)
  92       (pixmap-set pixmap source mask)
  93     (multiple-value-bind (source mask) (gdk:pixmap-create source)
  94       (pixmap-set pixmap source mask))))
  95
  96 (defun pixmap-new (source &optional mask)
  97   (make-instance 'pixmap :source source :mask mask))
  98
  99 (define-foreign pixmap-set () nil
 100   (pixmap pixmap)
 101   (source gdk:pixmap)
 102   (mask (or null gdk:bitmap)))
 103
 104 (defun (setf pixmap-source) (source pixmap)
 105   (if (typep source 'gdk:pixmap)
 106       (pixmap-set pixmap source (pixmap-mask pixmap))
 107     (multiple-value-bind (source mask) (gdk:pixmap-create source)
 108       (pixmap-set pixmap source mask)))
 109   source)
 110
 111 (defun (setf pixmap-mask) (mask pixmap)
 112   (pixmap-set pixmap (pixmap-source pixmap) mask)
 113   mask)
 114
 115 (define-foreign ("gtk_pixmap_get" pixmap-source) () nil
 116   (pixmap pixmap)
 117   (val gdk:pixmap :out)
 118   (nil null))
 119
 120 (define-foreign ("gtk_pixmap_get" pixmap-mask) () nil
 121   (pixmap pixmap)
 122   (nil null)
 123   (mask gdk:bitmap :out))
 124
 125
 126
 127 ;;; Bin
 128
 129 (defun bin-child (bin)
 130   (first (container-children bin)))
 131
 132 (defun (setf bin-child) (child bin)
 133   (let ((old-child (bin-child bin)))
 134     (when old-child
 135       (container-remove bin old-child)))
 136   (container-add bin child)
 137   child)
 138
 139 (defmethod initialize-instance ((bin bin) &rest initargs &key child)
 140   (declare (ignore initargs))
 141   (call-next-method)
 142   (cond
 143    ((consp child)
 144     (container-add bin (first child))
 145     (setf
 146      (slot-value (first child) 'child-slots)
 147      (apply
 148       #'make-instance
 149       (slot-value (class-of bin) 'child-class)
 150       :parent bin :child (first child) (cdr child))))
 151    (child
 152     (container-add bin child))))
 153
 154
 155 ;;; Alignment
 156
 157 (define-foreign alignment-new () alignment
 158   (xalign single-float)
 159   (ylign single-float)
 160   (xscale single-float)
 161   (yscale single-float))
 162
 163
 164
 165 ;;; Frame
 166
 167 (define-foreign frame-new (&optional label) frame
 168   (label string))
 169
 170
 171
 172 ;;; Aspect frame
 173
 174 (define-foreign aspect-frame-new () alignment
 175   (xalign single-float)
 176   (ylign single-float)
 177   (ratio single-float)
 178   (obey-child boolean))
 179
 180
 181
 182 ;;; Button
 183
 184 (define-foreign %button-new () button)
 185
 186 (define-foreign %button-new-with-label () button
 187   (label string))
 188
 189 (defun button-new (&optional label)
 190   (if label
 191       (%button-new-with-label label)
 192     (%button-new)))
 193
 194 (defgeneric button-label (button))
 195 (defgeneric (setf button-label) (label button))
 196
 197 (defmethod button-label ((button button))
 198   (object-arg button "GtkButton::label"))
 199
 200 (defmethod (setf button-label) ((label string) (button button))
 201   (setf (object-arg button "GtkButton::label") label))
 202
 203
 204 (define-foreign button-pressed () nil
 205   (button button))
 206
 207 (define-foreign button-released () nil
 208   (button button))
 209
 210 (define-foreign button-clicked () nil
 211   (button button))
 212
 213 (define-foreign button-enter () nil
 214   (button button))
 215
 216 (define-foreign button-leave () nil
 217   (button button))
 218
 219
 220
 221 ;;; Toggle button
 222
 223 (define-foreign %toggle-button-new () toggle-button)
 224
 225 (define-foreign %toggle-button-new-with-label () toggle-button
 226   (label string))
 227
 228 (defun toggle-button-new (&optional label)
 229   (if label
 230       (%toggle-button-new-with-label label)
 231     (%toggle-button-new)))
 232
 233 (define-foreign toggle-button-toggled () nil
 234   (toggle-button toggle-button))
 235
 236
 237
 238 ;;; Check button
 239
 240 (define-foreign %check-button-new () check-button)
 241
 242 (define-foreign %check-button-new-with-label () check-button
 243   (label string))
 244
 245 (defun check-button-new (&optional label)
 246   (if label
 247       (%check-button-new-with-label label)
 248     (%check-button-new)))
 249
 250 (defmethod (setf button-label) ((label string) (button check-button))
 251   (call-next-method)
 252   (setf (misc-xalign (bin-child button)) 0.0)
 253   label)
 254
 255
 256
 257 ;;; Radio button
 258
 259 (define-foreign %radio-button-new-with-label-from-widget () radio-button
 260   (widget (or null radio-button))
 261   (label string))
 262
 263 (define-foreign %radio-button-new-from-widget () radio-button
 264   (widget (or null radio-button)))
 265
 266 (defun radio-button-new (&optional label group-with)
 267   (if label
 268     (%radio-button-new-with-label-from-widget group-with label))
 269   (%radio-button-new-from-widget group-with))
 270
 271 (define-foreign ("gtk_radio_button_group" %radio-button-get-group) () pointer
 272   (radio-button radio-button))
 273
 274 (define-foreign %radio-button-set-group () nil
 275   (radio-button radio-button)
 276   (group pointer))
 277
 278 (defun radio-button-add-to-group (button1 button2)
 279   "Add BUTTON1 to the group which BUTTON2 belongs to."
 280   (%radio-button-set-group button1 (%radio-button-get-group button2)))
 281
 282 (defmethod initialize-instance ((button radio-button)
 283                                 &rest initargs &key group)
 284   (call-next-method)
 285   (when group
 286     (radio-button-add-to-group item group)))
 287
 288
 289 ;;; Option menu
 290
 291 (define-foreign option-menu-new () option-menu)
 292
 293 (define-foreign %option-menu-set-menu () nil
 294   (option-menu option-menu)
 295   (menu widget))
 296
 297 (define-foreign %option-menu-remove-menu () nil
 298   (option-menu option-menu))
 299
 300 (defun (setf option-menu-menu) (menu option-menu)
 301   (if (not menu)
 302       (%option-menu-remove-menu option-menu)
 303     (%option-menu-set-menu option-menu menu))
 304   menu)
 305
 306
 307
 308 ;;; Item
 309
 310 (define-foreign item-select () nil
 311   (item item))
 312
 313 (define-foreign item-deselect () nil
 314   (item item))
 315
 316 (define-foreign item-toggle () nil
 317   (item item))
 318
 319
 320
 321 ;;; Menu item
 322
 323 (define-foreign %menu-item-new () menu-item)
 324
 325 (define-foreign %menu-item-new-with-label () menu-item
 326   (label string))
 327
 328 (defun menu-item-new (&optional label)
 329   (if label
 330       (%menu-item-new-with-label label)
 331     (%menu-item-new)))
 332
 333 (defun (setf menu-item-label) (label menu-item)
 334   (make-instance 'accel-label
 335    :label label :xalign 0.0 :yalign 0.5 :accel-widget menu-item
 336    :visible t :parent menu-item)
 337   label)
 338
 339 (define-foreign %menu-item-set-submenu () nil
 340   (menu-item menu-item)
 341   (submenu menu))
 342
 343 (define-foreign %menu-item-remove-submenu () nil
 344   (menu-item menu-item))
 345
 346 (defun (setf menu-item-submenu) (submenu menu-item)
 347   (if (not submenu)
 348       (%menu-item-remove-submenu menu-item)
 349     (%menu-item-set-submenu menu-item submenu))
 350   submenu)
 351
 352 (define-foreign %menu-item-configure () nil
 353   (menu-item menu-item)
 354   (show-toggle-indicator boolean)
 355   (show-submenu-indicator boolean))
 356
 357 (defun (setf menu-item-toggle-indicator-p) (show menu-item)
 358   (%menu-item-configure
 359    menu-item
 360    show
 361    (menu-item-submenu-indicator-p menu-item))
 362   show)
 363
 364 (defun (setf menu-item-submenu-indicator-p) (show menu-item)
 365   (%menu-item-configure
 366    menu-item
 367    (menu-item-toggle-indicator-p menu-item)
 368    show))
 369
 370 (define-foreign menu-item-select () nil
 371   (menu-item menu-item))
 372
 373 (define-foreign menu-item-deselect () nil
 374   (menu-item menu-item))
 375
 376 (define-foreign menu-item-activate () nil
 377   (menu-item menu-item))
 378
 379 (define-foreign menu-item-right-justify () nil
 380   (menu-item menu-item))
 381
 382
 383
 384 ;;; Check menu item
 385
 386 (define-foreign %check-menu-item-new
 387     () check-menu-item)
 388
 389 (define-foreign %check-menu-item-new-with-label () check-menu-item
 390   (label string))
 391
 392 (defun check-menu-item-new (&optional label)
 393   (if label
 394       (%check-menu-item-new-with-label label)
 395     (%check-menu-item-new)))
 396
 397 (define-foreign check-menu-item-toggled () nil
 398   (check-menu-item check-menu-item))
 399
 400
 401
 402 ;;; Radio menu item
 403
 404 (define-foreign %radio-menu-item-new () radio-menu-item
 405   (group pointer))
 406
 407 (define-foreign %radio-menu-item-new-with-label () radio-menu-item
 408   (group pointer)
 409   (label string))
 410
 411 (define-foreign
 412     ("gtk_radio_menu_item_group" %radio-menu-item-get-group) () pointer
 413   (radio-menu-item radio-menu-item))
 414
 415 (define-foreign %radio-menu-item-set-group () nil
 416   (radio-menu-item radio-menu-item)
 417   (group pointer))
 418
 419 (defun radio-menu-item-new (&optional label group-with)
 420   (let ((group
 421          (if group-with
 422              (%radio-menu-item-get-group group-with)
 423            (make-pointer 0))))
 424     (if label
 425         (%radio-menu-item-new-with-label group label)
 426       (%radio-menu-item-new group))))
 427
 428 (defun radio-menu-item-add-to-group (item1 item2)
 429   "Add ITEM1 to the group which ITEM2 belongs to."
 430   (%radio-menu-item-set-group item1 (%radio-menu-item-get-group item2)))
 431
 432 (defmethod initialize-instance ((item radio-menu-item)
 433                                 &rest initargs &key group)
 434   (call-next-method)
 435   (when group
 436     (radio-menu-item-add-to-group item group)))
 437
 438
 439
 440 ;;; Tearoff menu item
 441
 442 (define-foreign tearoff-menu-item-new () tearoff-menu-item)
 443
 444
 445
 446 ;;; List item
 447
 448 (define-foreign %list-item-new () list-item)
 449
 450 (define-foreign %list-item-new-with-label () list-item
 451   (label string))
 452
 453 (defun list-item-new (&optional label)
 454   (if label
 455       (%list-item-new-with-label label)
 456     (%list-item-new)))
 457
 458 (define-foreign list-item-select () nil
 459   (list-item list-item))
 460
 461 (define-foreign list-item-deselect () nil
 462   (list-item list-item))
 463
 464
 465
 466 ;;; Tree item
 467
 468 (define-foreign %tree-item-new () tree-item)
 469
 470 (define-foreign %tree-item-new-with-label () tree-item
 471   (label string))
 472
 473 (defun tree-item-new (&optional label)
 474   (if label
 475       (%tree-item-new-with-label label)
 476     (%tree-item-new)))
 477
 478 (define-foreign %tree-item-set-subtree () nil
 479   (tree-item tree-item)
 480   (subtree tree))
 481
 482 (define-foreign %tree-item-remove-subtree () nil
 483   (tree-item tree-item))
 484
 485 (defun (setf tree-item-subtree) (subtree tree-item)
 486   (if subtree
 487       (%tree-item-set-subtree tree-item subtree)
 488     (%tree-item-remove-subtree tree-item))
 489   subtree)
 490
 491 (define-foreign tree-item-select () nil
 492   (tree-item tree-item))
 493
 494 (define-foreign tree-item-deselect () nil
 495   (tree-item tree-item))
 496
 497 (define-foreign tree-item-expand () nil
 498   (tree-item tree-item))
 499
 500 (define-foreign tree-item-collapse () nil
 501   (tree-item tree-item))
 502
 503
 504
 505 ;;; Window
 506
 507 (define-foreign window-new () window
 508   (type window-type))
 509
 510 (define-foreign %window-set-wmclass () nil
 511   (window window)
 512   (wmclass-name string)
 513   (wmclass-class string))
 514
 515 (defun (setf window-wmclass) (wmclass window)
 516   (%window-set-wmclass window (svref wmclass 0) (svref wmclass 1))
 517   (values (svref wmclass 0) (svref wmclass 1)))
 518
 519 ;; gtkglue.c
 520 (define-foreign window-wmclass () nil
 521   (window window)
 522   (wmclass-name string :out)
 523   (wmclass-class string :out))
 524
 525 (define-foreign window-add-accel-group () nil
 526   (window window)
 527   (accel-group accel-group))
 528
 529 (define-foreign window-remove-accel-group () nil
 530   (window window)
 531   (accel-group accel-group))
 532
 533 (define-foreign window-activate-focus () int
 534   (window window))
 535
 536 (define-foreign window-activate-default () int
 537   (window window))
 538
 539 (define-foreign window-set-transient-for () nil
 540   (window window)
 541   (parent window))
 542
 543 ;(define-foreign window-set-geometry-hints)
 544
 545
 546
 547 ;;; Dialog
 548
 549 (define-foreign dialog-new () dialog)
 550
 551
 552 ;;; Color selection dialog
 553
 554 (define-foreign color-selection-dialog-new () color-selection-dialog
 555   (title string))
 556
 557
 558 ;;; Input dialog
 559
 560 (define-foreign input-dialog-new () dialog)
 561
 562
 563
 564 ;;; File selection
 565
 566 (define-foreign file-selection-new () file-selection
 567   (title string))
 568
 569 (define-foreign file-selection-complete () nil
 570   (file-selection file-selection)
 571   (pattern string))
 572
 573 (define-foreign file-selection-show-fileop-buttons () nil
 574   (file-selection file-selection))
 575
 576 (define-foreign file-selection-hide-fileop-buttons () nil
 577   (file-selection file-selection))
 578
 579
 580
 581 ;;; Handle box
 582
 583 (define-foreign handle-box-new () handle-box)
 584
 585
 586
 587 ;;; Scrolled window
 588
 589 (define-foreign scrolled-window-new
 590     (&optional hadjustment vadjustment) scrolled-window
 591   (hadjustment (or null adjustment))
 592   (vadjustment (or null adjustment)))
 593
 594 (defun (setf scrolled-window-scrollbar-policy) (policy window)
 595   (setf (scrolled-window-hscrollbar-policy window) policy)
 596   (setf (scrolled-window-vscrollbar-policy window) policy))
 597
 598 (define-foreign scrolled-window-add-with-viewport () nil
 599    (scrolled-window scrolled-window)
 600    (child widget))
 601
 602
 603
 604 ;;; Viewport
 605
 606 (define-foreign viewport-new () viewport
 607   (hadjustment adjustment)
 608   (vadjustment adjustment))
 609
 610
 611
 612 ;;; Box
 613
 614 (define-foreign box-pack-start () nil
 615   (box box)
 616   (child widget)
 617   (expand boolean)
 618   (fill boolean)
 619   (padding unsigned-int))
 620
 621 (define-foreign box-pack-end () nil
 622   (box box)
 623   (child widget)
 624   (expand boolean)
 625   (fill boolean)
 626   (padding unsigned-int))
 627
 628 (defun box-pack (box child &key (pack :start) (expand t) (fill t) (padding 0))
 629   (if (eq pack :start)
 630       (box-pack-start box child expand fill padding)
 631     (box-pack-end box child expand fill padding)))
 632
 633 (define-foreign box-reorder-child () nil
 634   (box box)
 635   (child widget)
 636   (position int))
 637
 638 (define-foreign box-query-child-packing () nil
 639   (box box)
 640   (child widget :out)
 641   (expand boolean :out)
 642   (fill boolean :out)
 643   (padding unsigned-int :out)
 644   (pack-type pack-type :out))
 645
 646 (define-foreign box-set-child-packing () nil
 647   (box box)
 648   (child widget)
 649   (expand boolean)
 650   (fill boolean)
 651   (padding unsigned-int)
 652   (pack-type pack-type))
 653
 654
 655
 656 ;;; Button box
 657
 658 (define-foreign ("gtk_button_box_get_child_size_default"
 659                   button-box-get-default-child-size) () nil
 660   (min-width int :out)
 661   (min-height int :out))
 662
 663 (define-foreign ("gtk_button_box_set_child_size_default"
 664                  button-box-set-default-child-size) () nil
 665   (min-width int)
 666   (min-height int))
 667
 668 (define-foreign ("gtk_button_box_get_child_ipadding_default"
 669                   button-box-get-default-child-ipadding) () nil
 670   (ipad-x int :out)
 671   (ipad-y int :out))
 672
 673
 674 (define-foreign ("gtk_button_box_get_child_ipadding_default"
 675                  button-box-set-default-child-ipadding) () nil
 676   (ipad-x int)
 677   (ipad-y int))
 678
 679
 680
 681 ;;; HButton box
 682
 683 (define-foreign hbutton-box-new () hbutton-box)
 684
 685 (define-foreign ("gtk_hbutton_box_get_spacing_default"
 686                   hbutton-box-default-spacing) () int)
 687
 688 (define-foreign %hbutton-box-set-spacing-default () nil
 689   (spacing int))
 690
 691 (defun (setf hbutton-box-default-spacing) (spacing)
 692   (%hbutton-box-set-spacing-default spacing))
 693
 694 (define-foreign ("gtk_hbutton_box_get_layout_default"
 695                   hbutton-box-default-layout) () button-box-style)
 696
 697 (define-foreign %hbutton-box-set-layout-default () nil
 698   (layout button-box-style))
 699
 700 (defun (setf hbutton-box-default-layout) (layout)
 701   (%hbutton-box-set-layout-default layout))
 702
 703
 704
 705 ;;; VButton Box
 706
 707 (define-foreign vbutton-box-new () vbutton-box)
 708
 709 (define-foreign ("gtk_vbutton_box_get_spacing_default"
 710                   vbutton-box-default-spacing) () int)
 711
 712 (define-foreign %vbutton-box-set-spacing-default () nil
 713   (spacing int))
 714
 715 (defun (setf vbutton-box-default-spacing) (spacing)
 716   (%vbutton-box-set-spacing-default spacing))
 717
 718 (define-foreign ("gtk_vbutton_box_get_layout_default"
 719                   vbutton-box-default-layout) () button-box-style)
 720
 721 (define-foreign %vbutton-box-set-layout-default () nil
 722   (layout button-box-style))
 723
 724 (defun (setf vbutton-box-default-layout) (layout)
 725   (%vbutton-box-set-layout-default layout))
 726
 727
 728
 729 ;;; VBox
 730
 731 (define-foreign vbox-new () vbox
 732   (homogeneous boolean)
 733   (spacing int))
 734
 735
 736
 737 ;;; Color selection
 738
 739 (define-foreign color-selection-new () color-selection)
 740
 741 (define-foreign %color-selection-get-color () nil
 742   (colorsel color-selection)
 743   (color pointer))
 744
 745 (defun color-selection-color (colorsel)
 746   (let ((color (allocate-memory (* (size-of 'double-float) 4))))
 747     (%color-selection-get-color colorsel color)
 748     (funcall (get-from-alien-function '(vector double-float 4)) color)))
 749
 750 (define-foreign %color-selection-set-color () nil
 751   (colorsel color-selection)
 752   (color (vector double-float 4)))
 753
 754 (defun (setf color-selection-color) (color colorsel)
 755   (%color-selection-set-color colorsel color)
 756   color)
 757
 758 (define-foreign %color-selection-get-old-color () nil
 759   (colorsel color-selection)
 760   (color pointer))
 761
 762 (defun color-selection-old-color (colorsel)
 763   (let ((color (allocate-memory (* (size-of 'double-float) 4))))
 764     (%color-selection-get-old-color colorsel color)
 765     (funcall (get-from-alien-function '(vector double-float 4)) color)))
 766
 767 (define-foreign %color-selection-set-old-color () nil
 768   (colorsel color-selection)
 769   (color (vector double-float 4)))
 770
 771 (defun (setf color-selection-old-color) (color colorsel)
 772   (%color-selection-set-old-color colorsel color)
 773   color)
 774
 775 (define-foreign %color-selection-get-palette-color () boolean
 776   (colorsel color-selection)
 777   (x int)
 778   (y int)
 779   (color (vector double-float 4) :out))
 780
 781 (defun color-selection-palette-color (colorsel x y)
 782   (multiple-value-bind (color-set-p color)
 783       (%color-selection-get-palette-color colorsel x y)
 784     (and color-set-p color)))
 785
 786 (define-foreign %color-selection-set-palette-color () nil
 787   (colorsel color-selection)
 788   (x int)
 789   (y int)
 790   (color (vector double-float 4)))
 791
 792 (define-foreign %color-selection-unset-palette-color () nil
 793   (colorsel color-selection)
 794   (x int)
 795   (y int))
 796
 797 (defun (setf color-selection-palette-color) (color colorsel x y)
 798   (if color
 799       (%color-selection-set-palette-color colorsel x y color)
 800     (%color-selection-unset-palette-color colorsel x y))
 801   color)
 802
 803 (define-foreign ("gtk_color_selection_is_adjusting"
 804                  color-selection-is-adjusting-p) () boolean
 805   (colorsel color-selection))
 806
 807
 808
 809 ;;; Gamma curve
 810
 811 ;(define-foreign gamma-curve-new () gamma-curve)
 812
 813
 814
 815 ;;; HBox
 816
 817 (define-foreign hbox-new () hbox
 818   (homogeneous boolean)
 819   (spacing int))
 820
 821
 822
 823 ;;; Combo
 824
 825 (define-foreign combo-new () combo)
 826
 827 (define-foreign combo-set-value-in-list () nil
 828   (combo combo)
 829   (val boolean)
 830   (ok-if-empty boolean))
 831
 832 ; (define-foreign ("gtk_combo_set_item_string" (setf combo-item-string)) () nil
 833 ;   (combo combo)
 834 ;   (item item)
 835 ;   (item-value string))
 836
 837 (define-foreign %combo-set-popdown-strings () nil
 838   (combo combo)
 839   (strings (glist string)))
 840
 841 (defun (setf combo-popdown-strings) (strings combo)
 842   (%combo-set-popdown-strings combo strings)
 843   strings)
 844
 845 (define-foreign combo-disable-activate () nil
 846   (combo combo))
 847
 848
 849
 850 ;;; Statusbar
 851
 852 (define-foreign statusbar-new () statusbar)
 853
 854 (define-foreign
 855     ("gtk_statusbar_get_context_id" statusbar-context-id) () unsigned-int
 856   (statusbar statusbar)
 857   (context-description string))
 858
 859 (define-foreign statusbar-push () unsigned-int
 860   (statusbar statusbar)
 861   (context-id unsigned-int)
 862   (text string))
 863
 864 (define-foreign statusbar-pop () nil
 865   (statusbar statusbar)
 866   (context-id unsigned-int))
 867
 868 (define-foreign statusbar-remove () nil
 869   (statusbar statusbar)
 870   (context-id unsigned-int)
 871   (message-id unsigned-int))
 872
 873
 874
 875 ;;; Fixed
 876
 877 (define-foreign fixed-new () fixed)
 878
 879 (define-foreign fixed-put () nil
 880   (fixed fixed)
 881   (widget widget)
 882   (x (signed 16))
 883   (y (signed 16)))
 884
 885 (define-foreign fixed-move () nil
 886   (fixed fixed)
 887   (widget widget)
 888   (x (signed 16))
 889   (y (signed 16)))
 890
 891
 892
 893 ;;; Notebook
 894
 895 (define-foreign notebook-new () notebook)
 896
 897 (define-foreign ("gtk_notebook_insert_page_menu" notebook-insert-page)
 898     (notebook position child tab-label &optional menu-label) nil
 899   (notebook notebook)
 900   (child widget)
 901   ((if (stringp tab-label)
 902        (label-new tab-label)
 903      tab-label) widget)
 904   ((if (stringp menu-label)
 905        (label-new menu-label)
 906      menu-label) (or null widget))
 907   (position int))
 908
 909 (defun notebook-append-page (notebook child tab-label &optional menu-label)
 910   (notebook-insert-page notebook -1 child tab-label menu-label))
 911
 912 (defun notebook-prepend-page (notebook child tab-label &optional menu-label)
 913   (notebook-insert-page notebook 0 child tab-label menu-label))
 914
 915 (define-foreign notebook-remove-page () nil
 916   (notebook notebook)
 917   (page-num int))
 918
 919 ; (defun notebook-current-page-num (notebook)
 920 ;   (let ((page-num (notebook-current-page notebook)))
 921 ;     (if (= page-num -1)
 922 ;       nil
 923 ;       page-num)))
 924
 925 (define-foreign ("gtk_notebook_get_nth_page" notebook-nth-page-child) () widget
 926   (notebook notebook)
 927   (page-num int))
 928
 929 (defun notebook-page-child (notebook)
 930   (notebook-nth-page-child notebook (notebook-page notebook)))
 931
 932 (define-foreign %notebook-page-num () int
 933   (notebook notebook)
 934   (child widget))
 935
 936 (defun notebook-child-num (notebook child)
 937   (let ((page-num (%notebook-page-num notebook child)))
 938     (if (= page-num -1)
 939         nil
 940       page-num)))
 941
 942 (define-foreign notebook-next-page () nil
 943   (notebook notebook))
 944
 945 (define-foreign notebook-prev-page () nil
 946   (notebook notebook))
 947
 948 (define-foreign notebook-popup-enable () nil
 949   (notebook notebook))
 950
 951 (define-foreign notebook-popup-disable () nil
 952   (notebook notebook))
 953
 954 (define-foreign
 955     ("gtk_notebook_get_tab_label" notebook-tab-label) (notebook ref) widget
 956   (notebook notebook)
 957   ((if (typep ref 'widget)
 958        ref
 959      (notebook-nth-page-child notebook ref))
 960    widget))
 961
 962 (define-foreign %notebook-set-tab-label () nil
 963   (notebook notebook)
 964   (reference widget)
 965   (tab-label widget))
 966
 967 (defun (setf notebook-tab-label) (tab-label notebook reference)
 968   (let ((tab-label-widget (if (stringp tab-label)
 969                               (label-new tab-label)
 970                             tab-label)))
 971     (%notebook-set-tab-label
 972      notebook
 973      (if (typep reference 'widget)
 974          reference
 975        (notebook-nth-page-child notebook reference))
 976      tab-label-widget)
 977     tab-label-widget))
 978
 979 (define-foreign
 980     ("gtk_notebook_get_menu_label" notebook-menu-label) (notebook ref) widget
 981   (notebook notebook)
 982   ((if (typep ref 'widget)
 983        ref
 984      (notebook-nth-page-child notebook ref))
 985    widget))
 986
 987 (define-foreign %notebook-set-menu-label () nil
 988   (notebook notebook)
 989   (reference widget)
 990   (menu-label widget))
 991
 992 (defun (setf notebook-menu-label) (menu-label notebook reference)
 993   (let ((menu-label-widget (if (stringp menu-label)
 994                               (label-new menu-label)
 995                             menu-label)))
 996     (%notebook-set-menu-label
 997      notebook
 998      (if (typep reference 'widget)
 999          reference
1000        (notebook-nth-page-child notebook reference))
1001      menu-label-widget)
1002     menu-label-widget))
1003
1004 (define-foreign notebook-query-tab-label-packing (notebook ref) nil
1005   (notebook notebook)
1006   ((if (typep ref 'widget)
1007        ref
1008      (notebook-nth-page-child notebook ref))
1009    widget)
1010   (expand boolean :out)
1011   (fill boolean :out)
1012   (pack-type pack-type :out))
1013
1014 (define-foreign
1015     notebook-set-tab-label-packing (notebook ref expand fill pack-type) nil
1016   (notebook notebook)
1017   ((if (typep ref 'widget)
1018        ref
1019      (notebook-nth-page-child notebook ref))
1020    widget)
1021   (expand boolean)
1022   (fill boolean)
1023   (pack-type pack-type))
1024
1025 (define-foreign notebook-reorder-child () nil
1026   (notebook notebook)
1027   (child widget)
1028   (position int))
1029
1030
1031
1032 ;;; Font selection
1033
1034
1035
1036
1037 ;;; Paned
1038
1039 (define-foreign paned-pack1 () nil
1040   (paned paned)
1041   (child widget)
1042   (resize boolean)
1043   (shrink boolean))
1044
1045 (define-foreign paned-pack2 () nil
1046   (paned paned)
1047   (child widget)
1048   (resize boolean)
1049   (shrink boolean))
1050
1051 ;; gtkglue.c
1052 (define-foreign paned-child1 () widget
1053   (paned paned)
1054   (resize boolean :out)
1055   (shrink boolean :out))
1056
1057 ;; gtkglue.c
1058 (define-foreign paned-child2 () widget
1059   (paned paned)
1060   (resize boolean :out)
1061   (shrink boolean :out))
1062
1063 (defun (setf paned-child1) (child paned)
1064   (paned-pack1 paned child nil t))
1065
1066 (defun (setf paned-child2) (child paned)
1067   (paned-pack2 paned child t t))
1068
1069
1070 (define-foreign vpaned-new () vpaned)
1071
1072 (define-foreign hpaned-new () hpaned)
1073
1074
1075
1076 ;;; Layout
1077
1078 (define-foreign layout-new (&optional hadjustment vadjustment) layout
1079   (hadjustment (or null adjustment))
1080   (vadjustment (or null adjustment)))
1081
1082 (define-foreign layout-put () nil
1083   (layout layout)
1084   (widget widget)
1085   (x int)
1086   (y int))
1087
1088 (define-foreign layout-move () nil
1089   (layout layout)
1090   (widget widget)
1091   (x int)
1092   (y int))
1093
1094 (define-foreign layout-set-size () nil
1095   (layout layout)
1096   (width int)
1097   (height int))
1098
1099 ;; gtkglue.c
1100 (define-foreign layout-get-size () nil
1101   (layout layout)
1102   (width int :out)
1103   (height int :out))
1104
1105 (defun layout-x-size (layout)
1106   (nth-value 0 (layout-get-size layout)))
1107
1108 (defun layout-y-size (layout)
1109   (nth-value 1 (layout-get-size layout)))
1110
1111 (defun (setf layout-x-size) (x layout)
1112   (layout-set-size layout x (layout-y-size layout)))
1113
1114 (defun (setf layout-y-size) (y layout)
1115   (layout-set-size layout (layout-x-size layout) y))
1116
1117 (define-foreign layout-freeze () nil
1118   (layout layout))
1119
1120 (define-foreign layout-thaw () nil
1121   (layout layout))
1122
1123
1124
1125 ;;; List
1126
1127 ; (define-foreign list-new () list-widget)
1128
1129 ; (define-foreign list-insert-items () nil
1130 ;   (list list-widget)
1131 ;   (items (list list-item))
1132 ;   (position int))
1133
1134 ; (define-foreign list-append-items () nil
1135 ;   (list list-widget)
1136 ;   (items (glist list-item)))
1137
1138 ; (define-foreign list-prepend-items () nil
1139 ;   (list list-widget)
1140 ;   (items (glist list-item)))
1141
1142 ; (define-foreign %list-remove-items () nil
1143 ;   (list list-widget)
1144 ;   (items (glist list-item)))
1145
1146 ; (define-foreign %list-remove-items-no-unref () nil
1147 ;   (list list-widget)
1148 ;   (items (glist list-item)))
1149
1150 ; (defun list-remove-items (list items &key no-unref)
1151 ;   (if no-unref
1152 ;       (%list-remove-items-no-unref list items)
1153 ;     (%list-remove-items list items)))
1154
1155 ; (define-foreign list-clear-items () nil
1156 ;   (list list-widget)
1157 ;   (start int)
1158 ;   (end int))
1159
1160 ; (define-foreign list-select-item () nil
1161 ;   (list list-widget)
1162 ;   (item int))
1163
1164 ; (define-foreign list-unselect-item () nil
1165 ;   (list list-widget)
1166 ;   (item int))
1167
1168 ; (define-foreign list-select-child () nil
1169 ;   (list list-widget)
1170 ;   (child widget))
1171
1172 ; (define-foreign list-unselect-child () nil
1173 ;   (list list-widget)
1174 ;   (child widget))
1175
1176 ; (define-foreign list-child-position () int
1177 ;   (list list-widget)
1178 ;   (child widget))
1179
1180 ; (define-foreign list-extend-selection () nil
1181 ;   (list list-widget)
1182 ;   (scroll-type scroll-type)
1183 ;   (position single-float)
1184 ;   (auto-start-selection boolean))
1185
1186 ; (define-foreign list-start-selection () nil
1187 ;   (list list-widget))
1188
1189 ; (define-foreign list-end-selection () nil
1190 ;   (list list-widget))
1191
1192 ; (define-foreign list-select-all () nil
1193 ;   (list list-widget))
1194
1195 ; (define-foreign list-unselect-all () nil
1196 ;   (list list-widget))
1197
1198 ; (define-foreign list-scroll-horizontal () nil
1199 ;   (list list-widget)
1200 ;   (scroll-type scroll-type)
1201 ;   (position single-float))
1202
1203 ; (define-foreign list-scroll-vertical () nil
1204 ;   (list list-widget)
1205 ;   (scroll-type scroll-type)
1206 ;   (position single-float))
1207
1208 ; (define-foreign list-toggle-add-mode () nil
1209 ;   (list list-widget))
1210
1211 ; (define-foreign list-toggle-focus-row () nil
1212 ;   (list list-widget))
1213
1214 ; (define-foreign list-toggle-row () nil
1215 ;   (list list-widget)
1216 ;   (item list-item))
1217
1218 ; (define-foreign list-undo-selection () nil
1219 ;   (list list-widget))
1220
1221 ; (define-foreign list-end-drag-selection () nil
1222 ;   (list list-widget))
1223
1224 ; ;; gtkglue.c
1225 ; (define-foreign list-selection () (glist list-item)
1226 ;   (list list-widget))
1227
1228
1229
1230 ;;; Menu shell
1231
1232 (define-foreign menu-shell-insert () nil
1233   (menu-shell menu-shell)
1234   (menu-item menu-item)
1235   (position int))
1236
1237 (defun menu-shell-append (menu-shell menu-item)
1238   (menu-shell-insert menu-shell menu-item -1))
1239
1240 (defun menu-shell-prepend (menu-shell menu-item)
1241   (menu-shell-insert menu-shell menu-item 0))
1242
1243 (define-foreign menu-shell-deactivate () nil
1244   (menu-shell menu-shell))
1245
1246 (define-foreign menu-shell-select-item () nil
1247   (menu-shell menu-shell)
1248   (menu-item menu-item))
1249
1250 (define-foreign menu-shell-deselect () nil
1251   (menu-shell menu-shell))
1252
1253 (define-foreign menu-shell-activate-item () nil
1254   (menu-shell menu-shell)
1255   (menu-item menu-item)
1256   (fore-deactivate boolean))
1257
1258
1259
1260 ; ;;; Menu bar
1261
1262 (define-foreign menu-bar-new () menu-bar)
1263
1264 ; (define-foreign menu-bar-insert () nil
1265 ;   (menu-bar menu-bar)
1266 ;   (menu menu)
1267 ;   (position int))
1268
1269 ; (defun menu-bar-append (menu-bar menu)
1270 ;   (menu-bar-insert menu-bar menu -1))
1271
1272 ; (defun menu-bar-prepend (menu-bar menu)
1273 ;   (menu-bar-insert menu-bar menu 0))
1274
1275
1276
1277 ; ;;; Menu
1278
1279 (define-foreign menu-new () menu)
1280
1281 ; (defun menu-insert (menu menu-item position)
1282 ;   (menu-shell-insert menu menu-item position))
1283
1284 ; (defun menu-append (menu menu-item)
1285 ;   (menu-shell-append menu menu-item))
1286
1287 ; (defun menu-prepend (menu menu-item)
1288 ;   (menu-shell-prepend menu menu-item))
1289
1290 ;(defun menu-popup ...)
1291
1292 (define-foreign menu-reposition () nil
1293   (menu menu))
1294
1295 (define-foreign menu-popdown () nil
1296   (menu menu))
1297
1298 (define-foreign ("gtk_menu_get_active" menu-active) () widget
1299   (menu menu))
1300
1301 (define-foreign %menu-set-active () nil
1302   (menu menu)
1303   (index unsigned-int))
1304
1305 (defun (setf menu-active) (menu index)
1306   (%menu-set-active menu index))
1307
1308 ;(defun menu-attach-to-widget ...)
1309
1310 (define-foreign menu-detach () nil
1311   (menu menu))
1312
1313 (define-foreign ("gtk_menu_get_attach_widget" menu-attach-widget) () widget
1314   (menu menu))
1315
1316 (define-foreign menu-reorder-child () nil
1317   (menu menu)
1318   (menu-item menu-item)
1319   (position int))
1320
1321
1322
1323 ;;; Packer
1324
1325 (define-foreign packer-new () packer)
1326
1327 (define-foreign packer-add
1328     (packer child side anchor
1329      &key
1330      options
1331      (border-width (packer-default-border-width packer))
1332      (pad-x (packer-default-pad-x packer))
1333      (pad-y (packer-default-pad-y packer))
1334      (ipad-x (packer-default-ipad-x packer))
1335      (ipad-y (packer-default-ipad-y packer))) nil
1336   (packer packer)
1337   (child widget)
1338   (side side-type)
1339   (anchor anchor-type)
1340   (options packer-options)
1341   (border-width unsigned-int)
1342   (pad-x unsigned-int)
1343   (pad-y unsigned-int)
1344   (ipad-x unsigned-int)
1345   (ipad-y unsigned-int))
1346
1347 (define-foreign packer-set-child-packing () nil
1348   (packer packer)
1349   (child widget)
1350   (side side-type)
1351   (anchor anchor-type)
1352   (options packer-options)
1353   (border-width unsigned-int)
1354   (pad-x unsigned-int)
1355   (pad-y unsigned-int)
1356   (ipad-x unsigned-int)
1357   (ipad-y unsigned-int))
1358
1359 (define-foreign packer-reorder-child () nil
1360   (packer packer)
1361   (child widget)
1362   (position int))
1363
1364
1365
1366 ;;; Table
1367
1368 (define-foreign table-new () table
1369   (rows unsigned-int)
1370   (columns unsigned-int)
1371   (homogeneous boolean))
1372
1373 (define-foreign table-resize () nil
1374   (table table)
1375   (rows unsigned-int)
1376   (columns unsigned-int))
1377
1378 (define-foreign table-attach (table child left right top bottom
1379                                &key (x-options '(:expand :fill))
1380                                     (y-options '(:expand :fill))
1381                                     (x-padding 0) (y-padding 0)) nil
1382   (table table)
1383   (child widget)
1384   (left unsigned-int)
1385   (right unsigned-int)
1386   (top unsigned-int)
1387   (bottom unsigned-int)
1388   (x-options attach-options)
1389   (y-options attach-options)
1390   (x-padding unsigned-int)
1391   (y-padding unsigned-int))
1392
1393 (define-foreign %table-set-row-spacing () nil
1394   (table table)
1395   (row unsigned-int)
1396   (spacing unsigned-int))
1397
1398 (defun (setf table-row-spacing) (spacing table row)
1399   (%table-set-row-spacing table row spacing)
1400   spacing)
1401
1402 ;; gtkglue.c
1403 (define-foreign table-row-spacing (table row) unsigned-int
1404   (table table)
1405   ((progn
1406      (assert (and (>= row 0) (< row (table-rows table))))
1407      row) unsigned-int))
1408
1409 (define-foreign %table-set-col-spacing () nil
1410   (table table)
1411   (col unsigned-int)
1412   (spacing unsigned-int))
1413
1414 (defun (setf table-column-spacing) (spacing table column)
1415   (%table-set-col-spacing table column spacing)
1416   spacing)
1417
1418 ;; gtkglue.c
1419 (define-foreign table-column-spacing (table col) unsigned-int
1420   (table table)
1421   ((progn
1422      (assert (and (>= col 0) (< col (table-columns table))))
1423      col) unsigned-int))
1424
1425
1426 (defun %set-table-child-option (object slot flag value)
1427   (let ((options (child-slot-value object slot)))
1428     (cond
1429      ((and value (not (member flag options)))
1430       (setf (child-slot-value object slot) (cons flag options)))
1431      ((and (not value) (member flag options))
1432       (setf (child-slot-value object slot) (delete flag options))))))
1433
1434 (macrolet ((define-option-accessor (name slot flag)
1435              `(progn
1436                 (defun ,name (object)
1437                   (member ,flag (child-slot-value object ,slot)))
1438                 (defun (setf ,name) (value object)
1439                   (%set-table-child-option object ,slot ,flag value)))))
1440   (define-option-accessor table-child-x-expand-p :x-options :expand)
1441   (define-option-accessor table-child-y-expand-p :y-options :expand)
1442   (define-option-accessor table-child-x-shrink-p :x-options :shrink)
1443   (define-option-accessor table-child-y-shrink-p :y-options :shrink)
1444   (define-option-accessor table-child-x-fill-p :x-options :fill)
1445   (define-option-accessor table-child-y-fill-p :y-options :fill))
1446
1447
1448
1449 ;;; Toolbar
1450
1451 (define-foreign toolbar-new () toolbar
1452   (orientation orientation)
1453   (style toolbar-style))
1454
1455 ;; gtkglue.c
1456 (define-foreign toolbar-num-children () int
1457   (toolbar toolbar))
1458
1459 (defun %toolbar-position-num (toolbar position)
1460   (case position
1461     (:prepend 0)
1462     (:append (toolbar-num-children toolbar))
1463     (t
1464      (assert (and (>= position 0) (< position (toolbar-num-children toolbar))))
1465      position)))
1466
1467 (define-foreign %toolbar-insert-element () widget
1468   (toolbar toolbar)
1469   (type toolbar-child-type)
1470   (widget (or null widget))
1471   (text string)
1472   (tooltip-text string)
1473   (tooltip-private-text string)
1474   (icon (or null widget))
1475   (nil null)
1476   (nil null)
1477   (position int))
1478
1479 (defun toolbar-insert-element (toolbar position
1480                                &key tooltip-text tooltip-private-text
1481                                type widget icon text callback)
1482   (let* ((icon-widget (typecase icon
1483                        ((or null widget) icon)
1484                        (t (pixmap-new icon))))
1485          (toolbar-child
1486           (%toolbar-insert-element
1487            toolbar (or type (and widget :widget) :button)
1488            widget text tooltip-text tooltip-private-text icon-widget
1489            (%toolbar-position-num toolbar position))))
1490     (when callback
1491       (signal-connect toolbar-child 'clicked callback))
1492     toolbar-child))
1493
1494 (defun toolbar-append-element (toolbar &key tooltip-text tooltip-private-text
1495                                type widget icon text callback)
1496   (toolbar-insert-element
1497    toolbar :append :type type :widget widget :icon icon :text text
1498    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
1499    :callback callback))
1500
1501 (defun toolbar-prepend-element (toolbar &key tooltip-text tooltip-private-text
1502                                 type widget icon text callback)
1503   (toolbar-insert-element
1504    toolbar :prepend :type type :widget widget :icon icon :text text
1505    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text
1506    :callback callback))
1507
1508 (defun toolbar-insert-space (toolbar position)
1509   (toolbar-insert-element toolbar position :type :space))
1510
1511 (defun toolbar-append-space (toolbar)
1512   (toolbar-insert-space toolbar :append))
1513
1514 (defun toolbar-prepend-space (toolbar)
1515   (toolbar-insert-space toolbar :prepend))
1516
1517 (defun toolbar-insert-widget (toolbar widget position &key tooltip-text
1518                               tooltip-private-text callback)
1519   (toolbar-insert-element
1520    toolbar position :widget widget :tooltip-text tooltip-text
1521    :tooltip-private-text tooltip-private-text :callback callback))
1522
1523 (defun toolbar-append-widget (toolbar widget &key tooltip-text
1524                               tooltip-private-text callback)
1525   (toolbar-insert-widget
1526    toolbar widget :append :tooltip-text tooltip-text
1527    :tooltip-private-text tooltip-private-text :callback callback))
1528
1529 (defun toolbar-prepend-widget (toolbar widget &key tooltip-text
1530                                tooltip-private-text callback)
1531   (toolbar-insert-widget
1532    toolbar widget :prepend :tooltip-text tooltip-text
1533    :tooltip-private-text tooltip-private-text :callback callback))
1534
1535 (defun toolbar-insert-item (toolbar text icon position &key tooltip-text
1536                             tooltip-private-text callback)
1537   (toolbar-insert-element
1538    toolbar position :text text :icon icon :callback callback
1539    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1540
1541 (defun toolbar-append-item (toolbar text icon &key tooltip-text
1542                             tooltip-private-text callback)
1543   (toolbar-insert-item
1544    toolbar text icon :append :callback callback
1545    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1546
1547
1548 (defun toolbar-prepend-item (toolbar text icon &key tooltip-text
1549                              tooltip-private-text callback)
1550   (toolbar-insert-item
1551    toolbar text icon :prepend :callback callback
1552    :tooltip-text tooltip-text :tooltip-private-text tooltip-private-text))
1553
1554 (defun toolbar-enable-tooltips (toolbar)
1555   (setf (toolbar-tooltips-p toolbar) t))
1556
1557 (defun toolbar-disable-tooltips (toolbar)
1558   (setf (toolbar-tooltips-p toolbar) nil))
1559
1560
1561
1562 ;;; Tree
1563
1564 ; (define-foreign tree-new () tree)
1565
1566 ; (define-foreign tree-append () nil
1567 ;   (tree tree)
1568 ;   (tree-item tree-item))
1569
1570 ; (define-foreign tree-prepend () nil
1571 ;   (tree tree)
1572 ;   (tree-item tree-item))
1573
1574 ; (define-foreign tree-insert () nil
1575 ;   (tree tree)
1576 ;   (tree-item tree-item)
1577 ;   (position int))
1578
1579 ; (define-foreign tree-remove-items () nil
1580 ;   (tree tree)
1581 ;   (items (glist tree-item)))
1582
1583 ; (define-foreign tree-clear-items () nil
1584 ;   (tree tree)
1585 ;   (start int)
1586 ;   (end int))
1587
1588 ; (define-foreign tree-select-item () nil
1589 ;   (tree tree)
1590 ;   (item int))
1591
1592 ; (define-foreign tree-unselect-item () nil
1593 ;   (tree tree)
1594 ;   (item int))
1595
1596 ; (define-foreign tree-select-child () nil
1597 ;   (tree tree)
1598 ;   (tree-item tree-item))
1599
1600 ; (define-foreign tree-unselect-child () nil
1601 ;   (tree tree)
1602 ;   (tree-item tree-item))
1603
1604 ; (define-foreign tree-child-position () int
1605 ;   (tree tree)
1606 ;   (tree-item tree-item))
1607
1608 ; (defun root-tree-p (tree)
1609 ;   (eq (tree-root-tree tree) tree))
1610
1611 ; ;; gtkglue.c
1612 ; (define-foreign tree-selection () (glist tree-item)
1613 ;   (tree tree))
1614
1615
1616
1617 ;;; Calendar
1618
1619 (define-foreign calendar-new () calendar)
1620
1621 (define-foreign calendar-select-month () int
1622   (calendar calendar)
1623   (month unsigned-int)
1624   (year unsigned-int))
1625
1626 (define-foreign calendar-select-day () nil
1627   (calendar calendar)
1628   (day unsigned-int))
1629
1630 (define-foreign calendar-mark-day () int
1631   (calendar calendar)
1632   (day unsigned-int))
1633
1634 (define-foreign calendar-unmark-day () int
1635   (calendar calendar)
1636   (day unsigned-int))
1637
1638 (define-foreign calendar-clear-marks () nil
1639   (calendar calendar))
1640
1641 (define-foreign calendar-display-options () nil
1642   (calendar calendar)
1643   (options calendar-display-options))
1644
1645 (define-foreign ("gtk_calendar_get_date" calendar-date) () nil
1646   (calendar calendar)
1647   (year unsigned-int :out)
1648   (month unsigned-int :out)
1649   (day unsigned-int :out))
1650
1651 (define-foreign calendar-freeze () nil
1652   (calendar calendar))
1653
1654 (define-foreign calendar-thaw () nil
1655   (calendar calendar))
1656
1657
1658
1659 ;;; Drawing area
1660
1661 ; (define-foreign drawing-area-new () drawing-area)
1662
1663 ; (define-foreign ("gtk_drawing_area_size" %drawing-area-set-size) () nil
1664 ;   (drawing-area drawing-area)
1665 ;   (width int)
1666 ;   (height int))
1667
1668 ; (defun (setf drawing-area-size) (size drawing-area)
1669 ;   (%drawing-area-set-size drawing-area (svref size 0) (svref size 1))
1670 ;   (values (svref size 0) (svref size 1)))
1671
1672 ; ;; gtkglue.c
1673 ; (define-foreign ("gtk_drawing_area_get_size" drawing-area-size) () nil
1674 ;   (drawing-area drawing-area)
1675 ;   (width int :out)
1676 ;   (height int :out))
1677
1678
1679
1680 ; ;;; Curve
1681
1682
1683
1684 ; ;;; Editable
1685
1686 (define-foreign editable-select-region (editable &optional (start 0) end) nil
1687   (editable editable)
1688   (start int)
1689   ((or end -1) int))
1690
1691 (define-foreign editable-insert-text
1692     (editable text &optional (position 0)) nil
1693   (editable editable)
1694   (text string)
1695   ((length text) int)
1696   ((or position -1) int :in-out))
1697
1698 (defun editable-append-text (editable text)
1699   (editable-insert-text editable text nil))
1700
1701 (defun editable-prepend-text (editable text)
1702   (editable-insert-text editable text 0))
1703
1704 (define-foreign editable-delete-text (editable &optional (start 0) end) nil
1705   (editable editable)
1706   (start int)
1707   ((or end -1) int))
1708
1709 (define-foreign ("gtk_editable_get_chars" editable-text)
1710     (editable &optional (start 0) end) string
1711   (editable editable)
1712   (start int)
1713   ((or end -1) int))
1714
1715 (defun (setf editable-text) (text editable)
1716   (if text
1717       (editable-delete-text
1718        editable
1719        (editable-insert-text editable text))
1720     (editable-delete-text editable))
1721   text)
1722
1723 (define-foreign editable-cut-clipboard () nil
1724   (editable editable))
1725
1726 (define-foreign editable-copy-clipboard () nil
1727   (editable editable))
1728
1729 (define-foreign editable-paste-clipboard () nil
1730   (editable editable))
1731
1732 (define-foreign editable-claim-selection () nil
1733   (editable editable)
1734   (claim boolean)
1735   (time unsigned-int))
1736
1737 (define-foreign editable-delete-selection () nil
1738   (editable editable))
1739
1740 (define-foreign editable-changed () nil
1741   (editable editable))
1742
1743
1744
1745 ;;; Entry
1746
1747 (define-foreign %entry-new() entry)
1748
1749 (define-foreign %entry-new-with-max-length () entry
1750   (max (unsigned 16)))
1751
1752 (defun entry-new (&optional max)
1753   (if max
1754       (%entry-new-with-max-length max)
1755     (%entry-new)))
1756
1757
1758 ;;; Spin button
1759
1760 (define-foreign spin-button-new () spin-button
1761   (adjustment adjustment)
1762   (climb-rate single-float)
1763   (digits unsigned-int))
1764
1765 (defun spin-button-value-as-int (spin-button)
1766   (round (spin-button-value spin-button)))
1767
1768 (define-foreign spin-button-spin () nil
1769   (spin-button spin-button)
1770   (direction spin-type)
1771   (increment single-float))
1772
1773 (define-foreign spin-button-update () nil
1774   (spin-button spin-button))
1775
1776
1777
1778 ; ;;; Ruler
1779
1780 (define-foreign ruler-set-range () nil
1781   (ruler ruler)
1782   (lower single-float)
1783   (upper single-float)
1784   (position single-float)
1785   (max-size single-float))
1786
1787 (define-foreign ruler-draw-ticks () nil
1788   (ruler ruler))
1789
1790 (define-foreign ruler-draw-pos () nil
1791   (ruler ruler))
1792
1793 (define-foreign hruler-new () hruler)
1794
1795 (define-foreign vruler-new () vruler)
1796
1797
1798 ;;; Range
1799
1800 (define-foreign range-draw-background () nil
1801   (range range))
1802
1803 (define-foreign range-clear-background () nil
1804   (range range))
1805
1806 (define-foreign range-draw-trough () nil
1807   (range range))
1808
1809 (define-foreign range-draw-slider () nil
1810   (range range))
1811
1812 (define-foreign range-draw-step-forw () nil
1813   (range range))
1814
1815 (define-foreign range-slider-update () nil
1816   (range range))
1817
1818 (define-foreign range-trough-click () int
1819   (range range)
1820   (x int)
1821   (y int)
1822   (jump-perc single-float :out))
1823
1824 (define-foreign range-default-hslider-update () nil
1825   (range range))
1826
1827 (define-foreign range-default-vslider-update () nil
1828   (range range))
1829
1830 (define-foreign range-default-htrough-click () int
1831   (range range)
1832   (x int)
1833   (y int)
1834   (jump-perc single-float :out))
1835
1836 (define-foreign range-default-vtrough-click () int
1837   (range range)
1838   (x int)
1839   (y int)
1840   (jump-perc single-float :out))
1841
1842 (define-foreign range-default-hmotion () int
1843   (range range)
1844   (x-delta int)
1845   (y-delta int))
1846
1847 (define-foreign range-default-vmotion () int
1848   (range range)
1849   (x-delta int)
1850   (y-delta int))
1851
1852
1853
1854 ;;; Scale
1855
1856 (define-foreign scale-draw-value () nil
1857   (scale scale))
1858
1859 (define-foreign hscale-new () hscale
1860   (adjustment adjustment))
1861
1862 (define-foreign vscale-new () hscale
1863   (adjustment adjustment))
1864
1865
1866
1867 ;;; Scrollbar
1868
1869 (define-foreign hscrollbar-new () hscrollbar
1870   (adjustment adjustment))
1871
1872 (define-foreign vscrollbar-new () vscrollbar
1873   (adjustment adjustment))
1874
1875
1876
1877 ;;; Separator
1878
1879 (define-foreign vseparator-new () vseparator)
1880
1881 (define-foreign hseparator-new () hseparator)
1882
1883
1884
1885 ;;; Preview
1886
1887
1888
1889 ;;; Progress
1890
1891 (define-foreign progress-configure () adjustment
1892   (progress progress)
1893   (value single-float)
1894   (min single-float)
1895   (max single-float))
1896
1897 (define-foreign ("gtk_progress_get_text_from_value"
1898                   progress-text-from-value) () string
1899   (progress progress))
1900
1901 (define-foreign ("gtk_progress_get_percentage_from_value"
1902                   progress-percentage-from-value) () single-float
1903   (progress progress))
1904
1905
1906
1907 ;;; Progress bar
1908
1909 (define-foreign progress-bar-new () progress-bar)
1910
1911 (define-foreign progress-bar-pulse () nil
1912   (progress-bar progress-bar))
1913
1914
1915
1916 ;;; Adjustment
1917
1918 (define-foreign adjustment-new () adjustment
1919   (value single-float)
1920   (lower single-float)
1921   (upper single-float)
1922   (step-increment single-float)
1923   (page-increment single-float)
1924   (page-size single-float))
1925
1926 (define-foreign adjustment-changed () nil
1927   (adjustment adjustment))
1928
1929 (define-foreign adjustment-value-changed () nil
1930   (adjustment adjustment))
1931
1932 (define-foreign adjustment-clamp-page () nil
1933   (adjustment adjustment)
1934   (lower single-float)
1935   (upper single-float))
1936
1937
1938
1939 ;;; Tooltips
1940
1941 (define-foreign tooltips-new () tooltips)
1942
1943 (define-foreign tooltips-enable () nil
1944   (tooltips tooltips))
1945
1946 (define-foreign tooltips-disable () nil
1947   (tooltips tooltips))
1948
1949 (define-foreign tooltips-set-tip () nil
1950   (tooltips tooltips)
1951   (widget widget)
1952   (tip-text string)
1953   (tip-private string))
1954
1955 (define-foreign tooltips-set-colors (tooltips background foreground) nil
1956   (tooltips tooltips)
1957   ((gdk:ensure-color background) gdk:color)
1958   ((gdk:ensure-color foreground) gdk:color))
1959
1960 (define-foreign tooltips-force-window () nil
1961   (tooltips tooltips))
1962
1963
1964
1965 ;;; Rc
1966
1967 (define-foreign rc-add-default-file (filename) nil
1968   ((namestring (truename filename)) string))
1969
1970 (define-foreign rc-parse (filename) nil
1971   ((namestring (truename filename)) string))
1972
1973 (define-foreign rc-parse-string () nil
1974   (rc-string string))
1975
1976 (define-foreign rc-reparse-all () nil)
1977
1978 (define-foreign rc-get-style () style
1979   (widget widget))
1980
1981
1982
1983 ;;; Accelerator Groups
1984
1985 (define-foreign accel-group-new () accel-group)
1986
1987 (define-foreign accel-group-get-default () accel-group)
1988
1989 (deftype-method alien-ref accel-group (type-spec)
1990   (declare (ignore type-spec))
1991   '%accel-group-ref)
1992
1993 (deftype-method alien-unref accel-group (type-spec)
1994   (declare (ignore type-spec))
1995   '%accel-group-unref)
1996
1997 (define-foreign %accel-group-ref () accel-group
1998   (accel-group (or accel-group pointer)))
1999
2000 (define-foreign %accel-group-unref () nil
2001   (accel-group (or accel-group pointer)))
2002
2003 (define-foreign accel-group-activate (accel-group key modifiers) boolean
2004   (accel-group accel-group)
2005   ((gdk:keyval-from-name key) unsigned-int)
2006   (modifiers gdk:modifier-type))
2007
2008 (define-foreign accel-groups-activate (object key modifiers) boolean
2009   (object object)
2010   ((gdk:keyval-from-name key) unsigned-int)
2011   (modifiers gdk:modifier-type))
2012
2013 (define-foreign accel-group-attach () nil
2014   (accel-group accel-group)
2015   (object object))
2016
2017 (define-foreign accel-group-detach () nil
2018   (accel-group accel-group)
2019   (object object))
2020
2021 (define-foreign accel-group-lock () nil
2022   (accel-group accel-group))
2023
2024 (define-foreign accel-group-unlock () nil
2025   (accel-group accel-group))
2026
2027
2028 ;;; Accelerator Groups Entries
2029
2030 (define-foreign accel-group-get-entry (accel-group key modifiers) accel-entry
2031   (accel-group accel-group)
2032   ((gdk:keyval-from-name key) unsigned-int)
2033   (modifiers gdk:modifier-type))
2034
2035 (define-foreign accel-group-lock-entry (accel-group key modifiers) nil
2036   (accel-group accel-group)
2037   ((gdk:keyval-from-name key) unsigned-int)
2038   (modifiers gdk:modifier-type))
2039
2040 (define-foreign accel-group-unlock-entry (accel-group key modifiers) nil
2041   (accel-group accel-group)
2042   ((gdk:keyval-from-name key) unsigned-int)
2043   (modifiers gdk:modifier-type))
2044
2045 (define-foreign accel-group-add
2046     (accel-group key modifiers flags object signal) nil
2047   (accel-group accel-group)
2048   ((gdk:keyval-from-name key) unsigned-int)
2049   (modifiers gdk:modifier-type)
2050   (flags accel-flags)
2051   (object object)
2052   ((name-to-string signal) string))
2053
2054 (define-foreign accel-group-add (accel-group key modifiers object) nil
2055   (accel-group accel-group)
2056   ((gdk:keyval-from-name key) unsigned-int)
2057   (modifiers gdk:modifier-type)
2058   (object object))
2059
2060
2061 ;;; Accelerator Signals
2062
2063 (define-foreign accel-group-handle-add
2064     (object signal-id accel-group key modifiers flags) nil
2065   (object object)
2066   (signal-id unsigned-int)
2067   (accel-group accel-group)
2068   ((gdk:keyval-from-name key) unsigned-int)
2069   (modifiers gdk:modifier-type)
2070   (flags accel-flags))
2071
2072 (define-foreign accel-group-handle-remove
2073     (object accel-group key modifiers) nil
2074   (object object)
2075   (accel-group accel-group)
2076   ((gdk:keyval-from-name key) unsigned-int)
2077   (modifiers gdk:modifier-type))
2078
2079
2080
2081 ;;; Style
2082
2083 ; (define-foreign style-new () style)
2084
2085 ; (define-foreign style-copy () style
2086 ;   (style style))
2087
2088 (define-foreign %style-get-color () gdk:color
2089   (style style)
2090   (color-type color-type)
2091   (state-type state-type))
2092
2093 (define-foreign %style-set-color () gdk:color
2094   (style style)
2095   (color-type color-type)
2096   (state-type state-type)
2097   (color gdk:color))
2098
2099 (defun style-fg (style state)
2100   (%style-get-color style :foreground state))
2101
2102 (defun (setf style-fg) (color style state)
2103   (%style-set-color style :foreground state color))
2104
2105 (defun style-bg (style state)
2106   (%style-get-color style :background state))
2107
2108 (defun (setf style-bg) (color style state)
2109   (%style-set-color style :background state color))
2110
2111 (defun style-text (style state)
2112   (%style-get-color style :text state))
2113
2114 (defun (setf style-text) (color style state)
2115   (%style-set-color style :text state color))
2116
2117 (defun style-base (style state)
2118   (%style-get-color style :base state))
2119
2120 (defun (setf style-base) (color style state)
2121   (%style-set-color style :base state color))
2122
2123 (defun style-white (style)
2124   (%style-get-color style :white :normal))
2125
2126 (defun (setf style-white) (color style)
2127   (%style-set-color style :white :normal color))
2128
2129 (defun style-black (style)
2130   (%style-get-color style :black :normal))
2131
2132 (defun (setf style-black) (color style)
2133   (%style-set-color style :black :normal color))
2134
2135 (define-foreign style-get-gc () gdk:gc
2136   (style style)
2137   (color-type color-type)
2138   (state-type state-type))