(:bilevel 0)
(:full 1))
+(define-g-enum "GdkInterpType"
+ gdk-interp-type
+ (:export t :type-initializer "gdk_interp_type_get_type")
+ (:nearest 0)
+ (:tiles 1)
+ (:bilinear 2)
+ (:hyper 3))
+
+(define-g-enum "GdkPixbufRotation"
+ gdk-pixbuf-rotation
+ (:export t :type-initializer "gdk_pixbuf_rotation_get_type")
+ (:none 0)
+ (:counterclockwise 90)
+ (:upsidedown 180)
+ (:clockwise 270))
+
(define-g-enum "GdkColorspace" colorspace ()
:rgb)
((:cffi visual colormap-visual (g-object visual)
"gdk_colormap_get_visual" nil)
(:cffi screen colormap-screen (g-object screen)
- "gdk_colormap_get_screeen" nil)))
+ "gdk_colormap_get_screen" nil)))
(define-g-object-class "GdkScreen" screen (:type-initializer "gdk_screen_get_type")
((font-options screen-font-options "font-options" "gpointer" t t)
(glib:at-init ()
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-foreign-library gdk
- (:unix (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libgdk-x11-2.0.so.0" "libgdk-x11-2.0.so"))
+ (:darwin (:or "libgdk-x11-2.0.0.dylib" "libgdk-x11-2.0.dylib"))
(:windows "libgdk-win32-2.0-0.dll")
(t "libgdk-2.0"))
(define-foreign-library gdk-pixbuf
- (:unix (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libgdk_pixbuf-2.0.so.0" "libgdk_pixbuf-2.0.so"))
+ (:darwin (:or "libgdk_pixbuf-2.0.0.dylib" "libgdk_pixbuf-2.0.dylib"))
(:windows (:or "libgdk_pixbuf-win32-2.0-0" "libgdk_pixbuf-2.0-0.dll"))
(t "libgdk_pixbuf-2.0"))
-
+
(define-foreign-library gtk
- (:unix (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libgtk-x11-2.0.so.0" "libgtk-x11-2.0.so"))
+ (:darwin (:or "libgtk-x11-2.0.0.dylib" "libgtk-x11-2.0.dylib"))
(:windows (:or "libgtk-2.0-0.dll" "libgtk-win32-2.0-0.dll"))
(t "libgtk-2.0")))
(gdk-pixbuf-get-from-image pixbuf image (null-pointer) src-x src-y dest-x dest-y width height))
(export 'pixbuf-get-from-image)
+
+(defcfun gdk-pixbuf-scale-simple (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (dest-width :int)
+ (dest-height :int)
+ (interp-type gdk-interp-type))
+
+(defun pixbuf-scale-simple (pixbuf dest-width dest-height &key (interp-type :bilinear))
+ (gdk-pixbuf-scale-simple pixbuf dest-width dest-height interp-type))
+
+(export 'pixbuf-scale-simple)
+
+(defcfun (pixbuf-scale "gdk_pixbuf_scale") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type))
+
+(export 'pixbuf-scale)
+
+(defcfun (pixbuf-composite-color-simple "gdk_pixbuf_composite_color_simple") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (dest-width :int)
+ (dest-height :int)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int)
+ (check-size :int)
+ (color-1 :uint32)
+ (color-2 :uint32))
+
+(export 'pixbuf-composite-color-simple)
+
+(defcfun (pixbuf-composite "gdk_pixbuf_composite") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int))
+
+(export 'pixbuf-composite)
+
+(defcfun (pixbuf-composite-color "gdk_pixbuf_composite_color") :void
+ (src (g-object pixbuf))
+ (dest (g-object pixbuf))
+ (dest-x :int)
+ (dest-y :int)
+ (dest-width :int)
+ (dest-height :int)
+ (offset-x :double)
+ (offset-y :double)
+ (scale-x :double)
+ (scale-y :double)
+ (interp-type gdk-interp-type)
+ (overall-alpha :int)
+ (check-x :int)
+ (check-y :int)
+ (check-size :int)
+ (color-1 :uint32)
+ (color-2 :uint32))
+
+(export 'pixbuf-composite-color)
+
+(defcfun (pixbuf-rotate-simple "gdk_pixbuf_rotate_simple") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (angle gdk-pixbuf-rotation))
+
+(export 'pixbuf-rotate-simple)
+
+(defcfun (pixbuf-flip "gdk_pixbuf_flip") (g-object pixbuf :already-referenced)
+ (src (g-object pixbuf))
+ (horizontal :boolean))
+
+(export 'pixbuf-flip)
nil "gtk_menu_tool_button_set_arrow_tooltip_text")
(:cffi gtk::arrow-tooltip-markup gtk::menu-tool-button-arrow-tooltip-markup :string
nil "gtk_menu_tool_button_set_arrow_tooltip_markup"))
+ ("GtkRadioButton"
+ (:cffi gtk::group gtk::radio-button-group (gslist gtk::radio-button :free-from-foreign nil :free-to-foreign nil)
+ nil "gtk_radio_button_set_group"))
("GtkUIManager"
(:cffi gtk::accel-group gtk::ui-manager-accel-group g-object
"gtk_ui_manager_get_accel_group" nil))
("GtkFileChooser"
(:cffi gtk::current-name gtk::file-chooser-current-name (:string :free-to-foreign t :encoding :utf-8)
nil "gtk_file_chooser_set_current_name")
- (:cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
+ (:cond :+win32
+ :cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_filename_utf8" "gtk_file_chooser_set_filename_utf8")
+ (:cond :-win32
+ :cffi gtk::filename gtk::file-chooser-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_filename" "gtk_file_chooser_set_filename")
- (:cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t)
+ (:cond :+win32
+ :cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_current_folder_utf8" "gtk_file_chooser_set_current_folder_utf8")
+ (:cond :-win32
+ :cffi gtk::current-folder gtk::file-chooser-current-folder (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_current_folder" "gtk_file_chooser_set_current_folder")
(:cffi gtk::uri gtk::file-chooser-uri (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_uri" "gtk_file_chooser_set_uri")
(:cffi gtk::current-folder-uri gtk::file-chooser-current-folder-uri (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_current_folder_uri" "gtk_file_chooser_set_current_folder_uri")
- (:cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
+ (:cond :+win32
+ :cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_preview_filename_utf8" nil)
+ (:cond :-win32
+ :cffi gtk::preview-filename gtk::file-chooser-preview-filename (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_preview_filename" nil)
(:cffi gtk::preview-uri gtk::file-chooser-preview-uri (glib:g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_preview_uri" nil))
(:file "glib.quark")
(:file "glib.gerror")
(:file "glib.utils")
+ (:file "glib.rand")
(:file "gobject.init")
(:file "gobject.ffi.package")
(data :pointer)
(next :pointer))
+(defcfun g-slist-alloc (:pointer g-slist))
+
(defcfun g-slist-free :void (list (:pointer g-slist)))
(defun g-slist-next (list)
(until (null-pointer-p c))
(collect (convert-from-foreign (foreign-slot-value c 'g-slist 'data) (gslist-type-type type))))
(when (gslist-type-free-from-foreign type)
- (g-slist-free pointer))))
\ No newline at end of file
+ (g-slist-free pointer))))
+
+(defmethod translate-to-foreign (list (type gslist-type))
+ (let ((result (null-pointer)) last)
+ (iter (for item in list)
+ (for n = (g-slist-alloc))
+ (for ptr = (convert-to-foreign item (gslist-type-type type)))
+ (setf (foreign-slot-value n 'g-slist 'data) ptr)
+ (setf (foreign-slot-value n 'g-slist 'next) (null-pointer))
+ (when last
+ (setf (foreign-slot-value last 'g-slist 'next) n))
+ (setf last n)
+ (when (first-iteration-p)
+ (setf result n)))
+ result))
+
(at-init ()
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-foreign-library glib
- (:unix (:or "libglib-2.0.so.0" "libglib-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libglib-2.0.so.0" "libglib-2.0.so"))
+ (:darwin (:or "libglib-2.0.0.dylib" "libglib-2.0.dylib"))
(:windows "libglib-2.0-0.dll")
(t (:default "libglib-2.0"))))
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-foreign-library gthread
- (:unix (:or "libgthread-2.0.so.0" "libgthread-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libgthread-2.0.so.0" "libgthread-2.0.so"))
+ (:darwin (:or "libgthread-2.0.0.dylib" "libgthread-2.0.dylib"))
(:windows "libgthread-2.0-0.dll")
(t "libgthread-2.0")))
--- /dev/null
+(in-package :glib)
+
+(defcfun (random-set-seed "g_random_set_seed") :void
+ (seed :uint32))
+
+(export 'random-set-seed)
+
+(defcfun (random-int "g_random_int") :uint32)
+
+(export 'random-int)
+
+(defcfun (random-int-range "g_random_int_range") :int32
+ (begin :int32)
+ (end :int32))
+
+(export 'random-int-range)
+
+(defun random-boolean ()
+ (logtest (random-int) #X8000))
+
+(export 'random-boolean)
+
+(defcfun (random-double "g_random_double") :double)
+
+(export 'random-double)
+
+(defcfun (random-double-range "g_random_double_range") :double
+ (begin :double)
+ (end :double))
+
+(export 'random-double-range)
+
(write-char (char-downcase c) stream))
(write-string "_get_type" stream)))
+(defclass print-readtime-condition ()
+ ((condition :initarg :condition)))
+
+(defmethod print-object ((o print-readtime-condition) stream)
+ (format stream "#~A" (slot-value o 'condition)))
+
(defun get-g-class-definition (type &optional lisp-name-package)
(when (and (stringp type) (null (ignore-errors (gtype type))))
(let ((type-init-name (probable-type-init-name type)))
(,@(mapcar (lambda (property)
(property->property-definition name property))
own-properties)
- ,@(cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
+ ,@(mapcan (lambda (property-definition)
+ (if (eq :cond (car property-definition))
+ (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition))
+ (list property-definition)))
+ (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))))
(defun get-g-interface-definition (interface &optional lisp-name-package)
(when (and (stringp interface) (null (ignore-errors (gtype interface))))
,@(append (mapcar (lambda (property)
(property->property-definition name property))
properties)
- (cdr (find g-name *additional-properties* :key 'car :test 'string=))))))
+ (mapcan (lambda (property-definition)
+ (if (eq :cond (car property-definition))
+ (list (make-instance 'print-readtime-condition :condition (cadr property-definition)) (cddr property-definition))
+ (list property-definition)))
+ (cdr (find g-name *additional-properties* :key 'car :test 'string=)))))))
(defun get-g-class-definitions-for-root-1 (type)
(unless (member (gtype type) *generation-exclusions* :test 'g-type=)
(at-init ()
(eval-when (:compile-toplevel :load-toplevel :execute)
(cffi:define-foreign-library gobject
- (:unix (:or "libgobject-2.0.so.0" "libgobject-2.0.so"))
+ ((:and :unix (:not :darwin)) (:or "libgobject-2.0.so.0" "libgobject-2.0.so"))
+ (:darwin (:or "libgobject-2.0.0.dylib" "libgobject-2.0.dylib"))
(:windows "libgobject-2.0-0.dll")
(t "libgobject-2.0")))
(gethash name *registered-object-types*))
(defun get-g-object-lisp-type (g-type)
(setf g-type (gtype g-type))
- (loop
- while (not (null g-type))
- for lisp-type = (gethash (gtype-name g-type) *registered-object-types*)
- when lisp-type do (return lisp-type)
- do (setf g-type (g-type-parent g-type))))
+ (iter (while (not (null g-type)))
+ (for lisp-type = (gethash (gtype-name g-type) *registered-object-types*))
+ (when lisp-type
+ (return lisp-type))
+ (setf g-type (g-type-parent g-type))))
(defun make-g-object-from-pointer (pointer)
(let* ((g-type (g-type-from-instance pointer))
(:file "gtk.functions")
(:file "gtk.base-classes")
(:file "gtk.dialog")
+ (:file "gtk.about-dialog")
(:file "gtk.window")
(:file "gtk.window-group")
(:file "gtk.icon-factory")
(:file "gtk.paned")
(:file "gtk.child-properties")
(:file "gtk.widget")
+ (:file "gtk.tree-view-dnd")
(:file "gtk.builder")
(:file "gtk.assistant")
(:file "gtk.link-button")
--- /dev/null
+(in-package :gtk)
+
+(defvar *about-dialog-url-func* nil)
+
+(defcallback about-dialog-url-func-cb :void
+ ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+ (declare (ignore user-data))
+ (funcall *about-dialog-url-func* dialog link))
+
+(defcallback about-dialog-url-func-destroy-cb :void
+ ((data :pointer))
+ (declare (ignore data))
+ (setf *about-dialog-url-func* nil))
+
+(defcfun gtk-about-dialog-set-url-hook :void
+ (func :pointer)
+ (data :pointer)
+ (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-url-hook) (new-value)
+ (if new-value
+ (gtk-about-dialog-set-url-hook (callback about-dialog-url-func-cb)
+ (null-pointer)
+ (callback about-dialog-url-func-destroy-cb))
+ (gtk-about-dialog-set-url-hook (null-pointer)
+ (null-pointer)
+ (null-pointer)))
+ (setf *about-dialog-url-func* new-value))
+
+(export 'about-dialog-global-url-hook)
+
+(defvar *about-dialog-email-func* nil)
+
+(defcallback about-dialog-email-func-cb :void
+ ((dialog (g-object about-dialog)) (link (:string :free-from-foreign nil)) (user-data :pointer))
+ (declare (ignore user-data))
+ (funcall *about-dialog-email-func* dialog link))
+
+(defcallback about-dialog-email-func-destroy-cb :void
+ ((data :pointer))
+ (declare (ignore data))
+ (setf *about-dialog-email-func* nil))
+
+(defcfun gtk-about-dialog-set-email-hook :void
+ (func :pointer)
+ (data :pointer)
+ (destroy-notify :pointer))
+
+(defun (setf about-dialog-global-email-hook) (new-value)
+ (if new-value
+ (gtk-about-dialog-set-email-hook (callback about-dialog-email-func-cb)
+ (null-pointer)
+ (callback about-dialog-email-func-destroy-cb))
+ (gtk-about-dialog-set-email-hook (null-pointer)
+ (null-pointer)
+ (null-pointer)))
+ (setf *about-dialog-email-func* new-value))
+
+(export 'about-dialog-global-email-hook)
+
(:cffi current-name file-chooser-current-name
(:string :free-to-foreign t :encoding :utf-8) nil
"gtk_file_chooser_set_current_name")
+ #+win32
+ (:cffi filename file-chooser-filename
+ (g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_filename_utf8" "gtk_file_chooser_set_filename_utf8")
+ #-win32
(:cffi filename file-chooser-filename
(g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_filename" "gtk_file_chooser_set_filename")
+ #+win32
+ (:cffi current-folder file-chooser-current-folder
+ (g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_current_folder_utf8"
+ "gtk_file_chooser_set_current_folder_utf8")
+ #-win32
(:cffi current-folder file-chooser-current-folder
(g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_current_folder" "gtk_file_chooser_set_current_folder")
(g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_current_folder_uri"
"gtk_file_chooser_set_current_folder_uri")
+ #+win32
+ (:cffi preview-filename file-chooser-preview-filename
+ (g-string :free-from-foreign t :free-to-foreign t)
+ "gtk_file_chooser_get_preview_filename_utf8" nil)
+ #-win32
(:cffi preview-filename file-chooser-preview-filename
(g-string :free-from-foreign t :free-to-foreign t)
"gtk_file_chooser_get_preview_filename" nil)
(:superclass check-button :export t :interfaces
("AtkImplementorIface" "GtkActivatable" "GtkBuildable")
:type-initializer "gtk_radio_button_get_type")
- ((group radio-button-group "group" "GtkRadioButton" nil
- t)))
+ ((:cffi group radio-button-group
+ (gslist g-object :free-from-foreign nil
+ :free-to-foreign nil)
+ "gtk_radio_button_get_group" "gtk_radio_button_set_group")))
(define-g-object-class "GtkComboBox" combo-box
(:superclass bin :export t :interfaces
(defcfun gtk-grab-get-current g-object)
(defcfun gtk-grab-remove :void
- (widget g-object))
\ No newline at end of file
+ (widget g-object))
; TODO: gtk_color_selection_set_change_palette_with_screen_hook
-(defcfun (file-chooser-select-filename "gtk_file_chooser_select_filename") :boolean
+(defcfun (file-chooser-select-filename #+win32 "gtk_file_chooser_select_filename_utf8"
+ #-win32 "gtk_file_chooser_select_filename") :boolean
(file-chooser g-object)
(filename :string))
(export 'file-chooser-select-filename)
-(defcfun (file-chooser-unselect-filename "gtk_file_chooser_unselect_filename") :void
+(defcfun (file-chooser-unselect-filename #+win32 "gtk_file_chooser_unselect_filename_utf8"
+ #-win32 "gtk_file_chooser_unselect_filename") :void
(file-chooser g-object)
(filename :string))
(export 'file-chooser-unselect-all)
-(defcfun (file-chooser-filenames "gtk_file_chooser_get_filenames") (gslist (g-string :free-from-foreign t))
+(defcfun (file-chooser-filenames #+win32 "gtk_file_chooser_get_filenames_utf8"
+ #-win32 "gtk_file_chooser_get_filenames") (gslist (g-string :free-from-foreign t))
(file-chooser g-object))
(export 'file-chooser-filenames)
(export 'file-chooser-filters)
-(defcfun gtk-file-chooser-add-shortcut-folder :boolean
+(defcfun (gtk-file-chooser-add-shortcut-folder #+win32 "gtk_file_chooser_add_shortcut_folder_utf8"
+ #-win32 "gtk_file_chooser_add_shortcut_folder") :boolean
(file-chooser g-object)
(folder :string)
(error :pointer))
(export 'file-chooser-add-shortcut-folder)
-(defcfun gtk-file-chooser-remove-shortcut-folder :boolean
+(defcfun (gtk-file-chooser-remove-shortcut-folder #+win32 "gtk_file_chooser_remove_shortcut_folder_utf8"
+ #-win32 "gtk_file_chooser_remove_shortcut_folder") :boolean
(file-chooser g-object)
(folder :string)
(error :pointer))
(export 'file-chooser-remove-shortcut-folder)
-(defcfun (file-chooser-shortcut-folders "gtk_file_chooser_list_shortcut_folders") (gslist (g-string :free-from-foreign t))
+(defcfun (file-chooser-shortcut-folders #+win32 "gtk_file_chooser_list_shortcut_folders_utf8"
+ #-win32 "gtk_file_chooser_list_shortcut_folders") (gslist (g-string :free-from-foreign t))
(file-chooser g-object))
(export 'file-chooser-shortcut-folders)
(gethash id (tree-lisp-store-id-map tree)))
(defmethod tree-model-get-iter-impl ((store tree-lisp-store) iter path)
- (let* ((node (get-node-by-path store path))
- (node-idx (get-assigned-id store node)))
- (setf (tree-iter-stamp iter) 0
- (tree-iter-user-data iter) node-idx)))
+ (ignore-errors
+ (let* ((node (get-node-by-path store path))
+ (node-idx (get-assigned-id store node)))
+ (setf (tree-iter-stamp iter) 0
+ (tree-iter-user-data iter) node-idx))))
(defun get-node-by-iter (tree iter)
(get-node-by-id tree (tree-iter-user-data iter)))
(free-stable-pointer data))
(defcfun gtk-tree-view-column-set-cell-data-func :void
- (tree-column (g-object tree-column))
+ (tree-column (g-object tree-view-column))
(cell-renderer (g-object cell-renderer))
(func :pointer)
(func-data :pointer)
(allocate-stable-pointer function)
(callback gtk-tree-cell-data-func-destroy-cb)))
+(export 'tree-view-column-set-cell-data-function)
+
(defcfun (tree-view-column-clear-attributes "gtk_tree_view_column_clear_attributes") :void
(tree-column (g-object tree-column))
(cell-renderer (g-object cell-renderer)))
--- /dev/null
+(in-package :gtk)
+
+(define-vtable ("GtkTreeDragSource" tree-drag-source)
+ (:skip parent-instance g-type-interface)
+ ;;methods
+ (row-draggable (:boolean
+ (tree-drag-source g-object)
+ (path (g-boxed-foreign tree-path))))
+ (drag-data-get (:boolean
+ (tree-drag-source g-object)
+ (path (g-boxed-foreign tree-path))
+ (selection-data (g-boxed-foreign selection-data))))
+ (drag-data-delete (:boolean
+ (tree-drag-source g-object)
+ (path (g-boxed-foreign tree-path)))))
+
+(define-vtable ("GtkTreeDragDest" tree-drag-dest)
+ (:skip parent-instance g-type-interface)
+ ;;methods
+ (drag-data-received (:boolean
+ (tree-drag-dest g-object)
+ (path (g-boxed-foreign tree-path))
+ (selection-data (g-boxed-foreign selection-data))))
+ (row-drop-possible (:boolean
+ (tree-drag-dest g-object)
+ (path (g-boxed-foreign tree-path))
+ (selection-data (g-boxed-foreign selection-data)))))
+
(unless (eq (ui-prop-name prop) :var)
(appending (list (ui-prop-name prop) (ui-prop-value prop)))))))
-(defvar *ui-child-packers* (make-hash-table))
-
-(defmacro def-ui-child-packer (class (var child-def child) &body body)
- `(setf (gethash ',class *ui-child-packers*)
- (lambda (,var ,child-def ,child) ,@body)))
-
-(def-ui-child-packer container (w d child)
- (declare (ignore d))
- `(container-add ,w ,child))
-
-(defun get-ui-child-prop-value (d name required-p context)
- (let ((prop (find name (ui-child-props d) :key #'ui-prop-name)))
- (if (and required-p (null prop))
- (error "~A is a mandatory child property for ~A" name context)
- (when prop (ui-prop-value prop)))))
-
-(def-ui-child-packer box (b d child)
- (let ((expand-prop (find :expand (ui-child-props d) :key #'ui-prop-name))
- (fill-prop (find :fill (ui-child-props d) :key #'ui-prop-name))
- (padding-prop (find :padding (ui-child-props d) :key #'ui-prop-name))
- (pack-type-prop (find :pack-type (ui-child-props d) :key #'ui-prop-name)))
- `(progn
- (box-pack-start ,b ,child
- ,@(when expand-prop (list :expand (ui-prop-value expand-prop)))
- ,@(when fill-prop (list :fill (ui-prop-value fill-prop)))
- ,@(when padding-prop (list :padding (ui-prop-value padding-prop))))
- ,@(when pack-type-prop
- (list `(setf (box-child-pack-type ,b ,child) ,(ui-prop-value pack-type-prop)))))))
-
-(def-ui-child-packer paned (p d child)
- (let ((resize-prop (find :resize (ui-child-props d) :key #'ui-prop-name))
- (shrink-prop (find :shrink (ui-child-props d) :key #'ui-prop-name)))
- `(if (null (paned-child-1 ,p))
- (paned-pack-1 ,p ,child
- ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
- ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop))))
- (paned-pack-2 ,p ,child
- ,@(when resize-prop (list :resize (ui-prop-value resize-prop)))
- ,@(when shrink-prop (list :shrink (ui-prop-value shrink-prop)))))))
-
-(def-ui-child-packer table (table d child)
- `(table-attach ,table ,child
- ,(get-ui-child-prop-value d :left t "table packing")
- ,(get-ui-child-prop-value d :right t "table packing")
- ,(get-ui-child-prop-value d :top t "table packing")
- ,(get-ui-child-prop-value d :bottom t "table packing")
- ,@(let ((x-options (get-ui-child-prop-value d :x-options nil nil)))
- (when x-options
- (list :x-options x-options)))
- ,@(let ((y-options (get-ui-child-prop-value d :y-options nil nil)))
- (when y-options
- (list :y-options y-options)))
- ,@(let ((x-padding (get-ui-child-prop-value d :x-padding nil nil)))
- (when x-padding
- (list :x-padding x-padding)))
- ,@(let ((y-padding (get-ui-child-prop-value d :y-padding nil nil)))
- (when y-padding
- (list :y-padding y-padding)))))
-
-(defun get-child-packer-fn (d)
- (iter (for class first (find-class (ui-d-class d)) then (first (c2mop:class-direct-superclasses class)))
- (while class)
- (for packer = (gethash (class-name class) *ui-child-packers*))
- (when packer (return packer))))
-
-(defun get-child-packer (d var)
- (let ((fn (get-child-packer-fn d)))
- (when fn
- (let ((forms (iter (for child in (ui-d-children d))
- (for child-var = (ui-d-var (ui-child-v child)))
- (collect (funcall fn var child child-var)))))
- (when forms (cons 'progn forms))))))
-
-(defun get-ui-d-initializer (d var)
- (get-child-packer d var))
+(defgeneric pack-child (container child &key))
+
+(defmethod pack-child ((w container) child &key)
+ (container-add w child))
+
+(defmethod pack-child ((b box) child &key (expand t) (fill t) (padding 0) pack-type position)
+ (box-pack-start b child
+ :expand expand
+ :fill fill
+ :padding padding)
+ (when pack-type
+ (setf (box-child-pack-type b child) pack-type))
+ (when position
+ (setf (box-child-position b child) position)))
+
+(defmethod pack-child ((p paned) child &key (resize 'default) (shrink t))
+ (if (null (paned-child-1 p))
+ (paned-pack-1 p child
+ :resize (if (eq resize 'default) nil resize)
+ :shrink shrink)
+ (paned-pack-2 p child
+ :resize (if (eq resize 'default) t resize)
+ :shrink shrink)))
+
+(defmethod pack-child ((table table) child &key
+ left right top bottom
+ (x-options '(:expand :fill)) (y-options '(:expand :fill)) (x-padding 0) (y-padding 0))
+
+ (unless left
+ (error "left is a mandatory child property for table packing"))
+ (unless right
+ (error "right is a mandatory child property for table packing"))
+ (unless top
+ (error "top is a mandatory child property for table packing"))
+ (unless bottom
+ (error "bottom is a mandatory child property for table packing"))
+
+ (table-attach table child
+ :left left
+ :right right
+ :top top
+ :bottom bottom
+ :x-options x-options
+ :y-options y-options
+ :x-padding x-padding
+ :y-padding y-padding))
+
+(defmethod pack-child ((w tree-view) child &key)
+ (tree-view-append-column w child))
+
+(defmethod pack-child ((w tree-view-column) child &key (expand t) attributes)
+ (tree-view-column-pack-start w child :expand expand)
+ (iter (for a on attributes by #'cddr)
+ (tree-view-column-add-attribute w child
+ (first a)
+ (second a))))
+
+(defmethod pack-child ((b toolbar) child &key (expand 'default) (homogeneous 'default))
+ (toolbar-insert b child -1)
+ (unless (eq expand 'default)
+ (container-call-set-property b child "expand" expand +g-type-boolean+))
+ (unless (eq homogeneous 'default)
+ (container-call-set-property b child "homogeneous" homogeneous +g-type-boolean+)))
(defun set-ui-expansion-1 (d)
(when (ui-d-class d)
;; only direct-vars do not have class
(setf (ui-d-var d) (get-ui-d-var d)
- (ui-d-initform d) (get-ui-d-initform d))
- (setf (ui-d-initializer d) (get-ui-d-initializer d (ui-d-var d)))))
+ (ui-d-initform d) (get-ui-d-initform d))))
(defun set-ui-expansion (description)
(iter (for child in (ui-d-children description))
(let* ((description (parse-ui-description ui-description))
(items (flattened-ui-descriptions description)))
(set-ui-expansion description)
- `(let (,@(iter (for i in items)
- (collect (list (ui-d-var i)
- (ui-d-initform i)))))
- ,@(iter (for i in items)
- (when (ui-d-initializer i)
- (collect (ui-d-initializer i))))
+ `(let (,@(iter (for item in items)
+ (collect (list (ui-d-var item)
+ (ui-d-initform item)))))
+ ,@(iter (for item in items)
+ (appending (iter (for child in (ui-d-children item))
+ (for child-var = (ui-d-var (ui-child-v child)))
+ (let ((props
+ (iter (for p in (ui-child-props child))
+ (appending (list (ui-prop-name p) (ui-prop-value p))))))
+ (collect (list* 'pack-child (ui-d-var item) child-var props))))))
+
,@body)))
+
(glib:at-init ()
(eval-when (:compile-toplevel :load-toplevel :execute)
(define-foreign-library pango
- (:unix "libpango-1.0.so.0")
+ ((:and :unix (:not :darwin)) "libpango-1.0.so.0")
+ (:darwin (:or "libpango-1.0.0.dylib" "libpango-1.0.dylib"))
(:windows "libpango-1.0-0.dll")
(t (:default "libgpango-1.0"))))
projects / cl-gtk2.git / commitdiff