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