;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtk.lisp,v 1.12 2002-04-02 15:03:47 espen Exp $
+;; $Id: gtk.lisp,v 1.13 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
;;; Acccel group
+
;;; Acccel label
(defbinding accel-label-refetch () boolean
;;; Adjustment
+(defmethod shared-initialize ((adjustment adjustment) names &key value)
+ (prog1
+ (call-next-method)
+ ;; we need to make sure that the value is set last, otherwise it
+ ;; may be outside current limits
+ (when value
+ (setf (slot-value adjustment 'value) value))))
+
+
(defbinding adjustment-changed () nil
(adjustment adjustment))
(fill boolean)
(padding unsigned-int))
-(defun box-pack (box child &key from-end (expand t) (fill t) (padding 0))
+(defun box-pack (box child &key from-end expand fill (padding 0))
(if from-end
(box-pack-end box child expand fill padding)
(box-pack-start box child expand fill padding)))
;;;; Dialog
-(defmethod shared-initialize ((dialog dialog) names &rest initargs)
+(defmethod shared-initialize ((dialog dialog) names &rest initargs &key button)
(call-next-method)
(dolist (button-definition (get-all initargs :button))
- (apply #'dialog-add-button dialog button-definition)))
+ (apply #'dialog-add-button dialog (mklist button-definition))))
(defvar %*response-id-key* (gensym))
-(defun %dialog-find-response-id-num (dialog response-id &optional create-p error-p)
+(defun %dialog-find-response-id-num (dialog id &optional create-p error-p)
(or
- (cadr (assoc response-id (rest (type-expand-1 'response-type))))
- (let* ((response-ids (object-data dialog %*response-id-key*))
- (response-id-num (position response-id response-ids)))
+ (cadr (assoc id (rest (type-expand-1 'response-type))))
+ (let ((response-ids (object-data dialog %*response-id-key*)))
(cond
- (response-id-num)
- (create-p
- (cond
- (response-ids
- (setf (cdr (last response-ids)) (list response-id))
- (1- (length response-ids)))
- (t
- (setf (object-data dialog %*response-id-key*) (list response-id))
- 0)))
- (error-p
- (error "Invalid response: ~A" response-id))))))
+ ((and response-ids (position id response-ids :test #'equal)))
+ (create-p
+ (cond
+ (response-ids
+ (vector-push-extend id response-ids)
+ (1- (length response-ids)))
+ (t
+ (setf
+ (object-data dialog %*response-id-key*)
+ (make-array 1 :adjustable t :fill-pointer t :initial-element id))
+ 0)))
+ (error-p
+ (error "Invalid response: ~A" id))))))
(defun %dialog-find-response-id (dialog response-id-num)
(if (< response-id-num 0)
(car
(rassoc
(list response-id-num)
- (rest (type-expand-1 'response-type)) :test #'equalp))
- (nth response-id-num (object-data dialog %*response-id-key*))))
+ (rest (type-expand-1 'response-type)) :test #'equal))
+ (aref (object-data dialog %*response-id-key*) response-id-num )))
(defmethod signal-connect ((dialog dialog) signal function &key object after)
(object (funcall function object))
(t (funcall function)))))
:object t :after after))
- (t
- (call-next-method)))))
+ ((call-next-method)))))
(defbinding dialog-run () nil
(text string)
(response-id-num int))
-(defun dialog-add-button (dialog label &optional response-id default-p)
- (let* ((response-id-num
- (if response-id
- (%dialog-find-response-id-num dialog response-id t)
- (length (object-data dialog %*response-id-key*))))
- (button (%dialog-add-button dialog label response-id-num)))
- (unless response-id
- (%dialog-find-response-id-num dialog button t))
- (when default-p
- (%dialog-set-default-response dialog response-id-num))
+(defun dialog-add-button (dialog label &optional (response label)
+ &key default object after)
+ "Adds a button to the dialog. If no response is given, then label
+ will be used."
+ (let* ((id (if (functionp response)
+ label
+ response))
+ (id-num (%dialog-find-response-id-num dialog id t))
+ (button (%dialog-add-button dialog label id-num)))
+ (when (functionp response)
+ (signal-connect dialog id response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id-num))
button))
(action-widget widget)
(response-id-num int))
-(defun dialog-add-action-widget (dialog widget &optional (response-id widget)
- default-p)
- (let ((response-id-num (%dialog-find-response-id-num dialog response-id t)))
- (%dialog-add-action-widget dialog widget response-id-num)
- (when default-p
- (%dialog-set-default-response dialog response-id-num))
+(defun dialog-add-action-widget (dialog widget &optional (response widget)
+ &key default object after)
+ (let* ((id (if (functionp response)
+ widget
+ response))
+ (id-num (%dialog-find-response-id-num dialog id t)))
+ (%dialog-add-action-widget dialog widget id-num)
+ (when (functionp response)
+ (signal-connect dialog id response :object object :after after))
+ (when default
+ (%dialog-set-default-response dialog id-num))
widget))
;; Addition dialog functions
(defmethod container-add ((dialog dialog) (child widget) &rest args)
- (apply #'container-add (slot-value dialog 'main-area) child args))
+ (apply #'container-add (dialog-vbox dialog) child args))
(defmethod container-remove ((dialog dialog) (child widget))
- (container-remove (slot-value dialog 'main-area) child))
+ (container-remove (dialog-vbox dialog) child))
(defmethod container-children ((dialog dialog))
- (container-children (dialog-main-area dialog)))
+ (container-children (dialog-vbox dialog)))
(defmethod (setf container-children) (children (dialog dialog))
- (setf (container-children (dialog-main-area dialog)) children))
+ (setf (container-children (dialog-vbox dialog)) children))
(y int :out))
+;;; Image
+
+(defbinding image-set-from-file () nil
+ (image image)
+ (filename pathname))
+
+(defbinding image-set-from-pixmap () nil
+ (image image)
+ (pixmap gdk:pixmap)
+ (mask gdk:bitmap))
+
+(defbinding image-set-from-stock () nil
+ (image image)
+ (stock-id string)
+ (icon-size icon-size))
+
+(defun image-set-from-pixmap-data (image pixmap-data)
+ (multiple-value-bind (pixmap mask) (gdk:pixmap-create pixmap-data)
+ (image-set-from-pixmap image pixmap mask)))
+
+(defun image-set-from-source (image source)
+ (etypecase source
+ (pathname (image-set-from-file image source))
+ (string (if (stock-lookup source)
+ (setf (image-stock image) source)
+ (image-set-from-file image source)))
+ (vector (image-set-from-pixmap-data image source))))
+
+
+(defmethod shared-initialize ((image image) names &rest initargs
+ &key file pixmap source)
+ (prog1
+ (if (vectorp pixmap)
+ (progn
+ (remf initargs :pixmap)
+ (apply #'call-next-method image names initargs))
+ (call-next-method))
+ (cond
+ (file (image-set-from-file image file))
+ ((vectorp pixmap) (image-set-from-pixmap-data image pixmap))
+ (source (image-set-from-source image source)))))
+
;;; Label
(defbinding label-get-layout-offsets () nil
- (labe label)
+ (label label)
(x int :out)
(y int :out))
(start int)
(end int))
-(defbinding label-get-text () string
+(defbinding label-get-text () string
(label label))
(defbinding label-get-layout () pango:layout
(label label))
-(defbinding label-get-selection-bounds () boolean
+(defbinding label-get-selection-bounds () boolean
(label label)
(start int :out)
(end int :out))
-;;; File selection
+;;; File chooser
-(defbinding file-selection-complete () nil
- (file-selection file-selection)
- (pattern string))
(keyword (case page
(:first 0)
(:last -1)
- (error "Invalid position keyword: ~A" page)))
+ (t (error "Invalid position keyword: ~A" page))))
(widget (notebook-page-num notebook page t))))
(defun %notebook-child (notebook position)
(defbinding notebook-remove-page (notebook page) nil
(notebook notebook)
- ((%notebook-position notebook position) int))
+ ((%notebook-position notebook page) int))
(defbinding %notebook-page-num () int
(notebook notebook)
(:last -1)
(t page)) int))
-(defbinding (notebook-current-page-num "gtk_notebook_get_current_page") () int
+
+(defbinding %notebook-get-current-page () int
(notebook notebook))
+(defun notebook-current-page-num (notebook)
+ (let ((num (%notebook-get-current-page notebook)))
+ (when (>= num 0)
+ num)))
+
(defun notebook-current-page (notebook)
- (notebook-nth-page-child notebook (notebook-current-page-num notebook)))
+ (let ((page-num (notebook-current-page-num notebook)))
+ (when page-num
+ (notebook-nth-page-child notebook page-num))))
(defbinding %notebook-set-current-page () nil
(notebook notebook)
page)
-;; (defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
-;; (notebook page) widget
-;; (notebook notebook)
-;; ((%notebook-child notebook page) widget))
-
-;; (defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
-;; (notebook page) string
-;; (notebook notebook)
-;; ((%notebook-child notebook page) widget))
-
-;; (defbinding %notebook-set-tab-label () nil
-;; (notebook notebook)
-;; (page widget)
-;; (tab-label widget))
+(defbinding (notebook-tab-label "gtk_notebook_get_tab_label")
+ (notebook page) widget
+ (notebook notebook)
+ ((%notebook-child notebook page) widget))
-;; (defun (setf notebook-tab-label) (tab-label notebook page)
-;; (let ((widget (if (stringp tab-label)
-;; (make-instance 'label :label tab-label)
-;; tab-label)))
-;; (%notebook-set-tab-label notebook (%notebook-child notebook page) widget)
-;; widget))
+(defbinding (notebook-tab-label-text "gtk_notebook_get_tab_label_text")
+ (notebook page) string
+ (notebook notebook)
+ ((%notebook-child notebook page) widget))
+(defbinding %notebook-set-tab-label () nil
+ (notebook notebook)
+ (page widget)
+ (tab-label widget))
+
+(defun (setf notebook-tab-label) (tab-label notebook page)
+ (let ((widget (if (stringp tab-label)
+ (make-instance 'label :label tab-label)
+ tab-label)))
+ (%notebook-set-tab-label notebook (%notebook-child notebook page) widget)
+ widget))
-;; (defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
-;; (notebook page) widget
-;; (notebook notebook)
-;; ((%notebook-child notebook page) widget))
-;; (defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
-;; (notebook page) string
-;; (notebook notebook)
-;; ((%notebook-child notebook page) widget))
+(defbinding (notebook-menu-label "gtk_notebook_get_menu_label")
+ (notebook page) widget
+ (notebook notebook)
+ ((%notebook-child notebook page) widget))
-;; (defbinding %notebook-set-menu-label () nil
-;; (notebook notebook)
-;; (page widget)
-;; (menu-label widget))
+(defbinding (notebook-menu-label-text "gtk_notebook_get_menu_label_text")
+ (notebook page) string
+ (notebook notebook)
+ ((%notebook-child notebook page) widget))
-;; (defun (setf notebook-menu-label) (menu-label notebook page)
-;; (let ((widget (if (stringp menu-label)
-;; (make-instance 'label :label menu-label)
-;; menu-label)))
-;; (%notebook-set-menu-label notebook (%notebook-child notebook page) widget)
-;; widget))
+(defbinding %notebook-set-menu-label () nil
+ (notebook notebook)
+ (page widget)
+ (menu-label widget))
+
+(defun (setf notebook-menu-label) (menu-label notebook page)
+ (let ((widget (if (stringp menu-label)
+ (make-instance 'label :label menu-label)
+ menu-label)))
+ (%notebook-set-menu-label notebook (%notebook-child notebook page) widget)
+ widget))
(defbinding notebook-query-tab-label-packing (notebook page) nil
(keyword (case child
(:first 0)
(:last -1)
- (error "Invalid position keyword: ~A" child)))
+ (t (error "Invalid position keyword: ~A" child))))
(widget (menu-child-position menu child))))
&key tooltip-text tooltip-private-text
type icon group callback object)
(let* ((numpos (case position
- (:first 0)
- (:last -1)
+ (:first -1)
+ (:last 0)
(t position)))
(widget
(cond
((typep element 'string)
(%toolbar-insert-element
toolbar (or type :button) (when (eq type :radio-button) group)
- element tooltip-text tooltip-private-text icon numpos))
+ element tooltip-text tooltip-private-text
+ (etypecase icon
+ (null nil)
+ (widget icon)
+ ((or pathname string vector)
+ (make-instance 'image
+ :source icon ; :icon-size (toolbar-icon-size toolbar)
+ )))
+ numpos))
((error "Invalid element type: ~A" element)))))
(when callback
(signal-connect widget 'clicked callback :object object))
;;; Editable
-#|
+
(defbinding editable-select-region (editable &optional (start 0) end) nil
(editable editable)
(start int)
((or end -1) int))
+(defbinding editable-get-selection-bounds (editable) nil
+ (editable editable)
+ (start int :out)
+ (end int :out))
+
(defbinding editable-insert-text
(editable text &optional (position 0)) nil
(editable editable)
(defbinding editable-paste-clipboard () nil
(editable editable))
-; (defbinding editable-claim-selection () nil
-; (editable editable)
-; (claim boolean)
-; (time unsigned-int))
-
(defbinding editable-delete-selection () nil
(editable editable))
-; (defbinding editable-changed () nil
-; (editable editable))
-|#
;;; Spin button
;;; Range
-#|
-(defbinding range-draw-background () nil
- (range range))
-(defbinding range-clear-background () nil
- (range range))
+(defun range-lower (range)
+ (adjustment-lower (range-adjustment range)))
-(defbinding range-draw-trough () nil
- (range range))
+(defun range-upper (range)
+ (adjustment-upper (range-adjustment range)))
-(defbinding range-draw-slider () nil
- (range range))
+(defun (setf range-lower) (value range)
+ (setf (adjustment-lower (range-adjustment range)) value))
-(defbinding range-draw-step-forw () nil
- (range range))
-
-(defbinding range-slider-update () nil
- (range range))
-
-(defbinding range-trough-click () int
- (range range)
- (x int)
- (y int)
- (jump-perc single-float :out))
+(defun (setf range-upper) (value range)
+ (setf (adjustment-upper (range-adjustment range)) value))
-(defbinding range-default-hslider-update () nil
- (range range))
+(defun range-page-increment (range)
+ (adjustment-page-increment (range-adjustment range)))
-(defbinding range-default-vslider-update () nil
- (range range))
+(defun range-step-increment (range)
+ (adjustment-step-increment (range-adjustment range)))
-(defbinding range-default-htrough-click () int
- (range range)
- (x int)
- (y int)
- (jump-perc single-float :out))
+(defun (setf range-page-increment) (value range)
+ (setf (adjustment-page-increment (range-adjustment range)) value))
-(defbinding range-default-vtrough-click () int
- (range range)
- (x int)
- (y int)
- (jump-perc single-float :out))
+(defun (setf range-step-increment) (value range)
+ (setf (adjustment-step-increment (range-adjustment range)) value))
-(defbinding range-default-hmotion () int
+(defbinding range-set-range () nil
(range range)
- (x-delta int)
- (y-delta int))
+ (lower double-float)
+ (upper double-float))
-(defbinding range-default-vmotion () int
+(defbinding range-set-increments () nil
(range range)
- (x-delta int)
- (y-delta int))
-|#
+ (step double-float)
+ (page double-float))
;;; Scale
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkcontainer.lisp,v 1.8 2002-03-24 21:56:34 espen Exp $
+;; $Id: gtkcontainer.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
-(defmethod shared-initialize ((container container) names &rest initargs)
+(defmethod shared-initialize ((container container) names &rest initargs
+ &key child children child-args)
+ (declare (ignore child))
(call-next-method)
- (dolist (child (get-all initargs :child))
- (apply #'container-add container (mklist child))))
+ (dolist (child (append children (get-all initargs :child)))
+ (apply #'container-add container (append (mklist child) child-args))))
(defbinding %container-add () nil
(defun map-container (seqtype func container)
(case seqtype
((nil)
- (%container-foreach container func)
+ (container-foreach container func)
nil)
(list
(let ((list nil))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkobject.lisp,v 1.15 2002-04-02 15:07:33 espen Exp $
+;; $Id: gtkobject.lisp,v 1.16 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
(:alien-name "GtkObject")))
-(defmethod shared-initialize ((object %object) names &rest initargs
- &allow-other-keys)
- (declare (ignore names))
+(defmethod shared-initialize ((object %object) names &rest initargs &key signal)
+ (declare (ignore names signal))
(call-next-method)
(object-ref object) ; inc ref count before sinking
(%object-sink object)
(defbinding %object-sink () nil
(object %object))
-
;;;; Main loop, timeouts and idle functions
(declaim (inline events-pending-p main-iteration))
(main-iteration-do nil)
(main-iterate-all)))
-(system:add-fd-handler (gdk:connection-number) :input #'main-iterate-all)
-(setq lisp::*periodic-polling-function* #'main-iterate-all)
-(setq lisp::*max-event-to-sec* 0)
-(setq lisp::*max-event-to-usec* 1000)
+;;;; Initalization
+
+(defbinding (gtk-init "gtk_parse_args") () nil
+ "Initializes the library without opening the display."
+ (nil null)
+ (nil null))
+
+
+(defun clg-init (&optional display)
+ "Initializes the system and starts the event handling"
+ (unless (gdk:display-get-default)
+ (gdk:gdk-init)
+ (gtk-init)
+ (prog1
+ (gdk:display-open display)
+ (system:add-fd-handler
+ (gdk:display-connection-number) :input #'main-iterate-all)
+ (setq lisp::*periodic-polling-function* #'main-iterate-all)
+ (setq lisp::*max-event-to-sec* 0)
+ (setq lisp::*max-event-to-usec* 1000))))
(defvar *container-to-child-class-mappings* (make-hash-table))
(eval-when (:compile-toplevel :load-toplevel :execute)
- (defclass child-class (virtual-slot-class))
+ (defclass child-class (virtual-slot-class)
+ ())
(defclass direct-child-slot-definition (direct-virtual-slot-definition)
- ((pname :reader slot-definition-pname)))
+ ((pname :reader slot-definition-pname :initarg :pname)))
- (defclass effective-child-slot-definition
- (effective-virtual-slot-definition)))
+ (defclass effective-child-slot-definition (effective-virtual-slot-definition)
+ ((pname :reader slot-definition-pname :initarg :pname)))
-(defmethod shared-initialize ((class child-class) names &rest initargs
- &key container)
- (declare (ignore initargs))
+(defmethod shared-initialize ((class child-class) names &key container)
(call-next-method)
(setf
(gethash (find-class (first container)) *container-to-child-class-mappings*)
class))
-(defmethod initialize-instance ((slotd direct-child-slot-definition)
- &rest initargs &key pname)
- (declare (ignore initargs))
- (call-next-method)
- (if pname
- (setf (slot-value slotd 'pname) pname)
- ; ???
- (error "Need pname for slot with allocation :property")))
+;; (defmethod initialize-instance ((slotd direct-child-slot-definition)
+;; &rest initargs &key pname)
+;; (declare (ignore initargs))
+;; (call-next-method)
+;; (if pname
+;; (setf (slot-value slotd 'pname) pname)
+;; ; ???
+;; (error "Need pname for slot with allocation :property")))
-(defmethod direct-slot-definition-class ((class child-class) initargs)
+(defmethod direct-slot-definition-class ((class child-class) &rest initargs)
(case (getf initargs :allocation)
(:property (find-class 'direct-child-slot-definition))
(t (call-next-method))))
-(defmethod effective-slot-definition-class ((class child-class) initargs)
+(defmethod effective-slot-definition-class ((class child-class) &rest initargs)
(case (getf initargs :allocation)
(:property (find-class 'effective-child-slot-definition))
(t (call-next-method))))
+(defmethod compute-effective-slot-definition-initargs ((class child-class) direct-slotds)
+ (if (eq (most-specific-slot-value direct-slotds 'allocation) :property)
+ (nconc
+ (list :pname (most-specific-slot-value direct-slotds 'pname))
+ (call-next-method))
+ (call-next-method)))
+
(progn
(declaim (optimize (ext:inhibit-warnings 3)))
(defun %container-child-get-property (parent child pname gvalue))
(defun %container-child-set-property (parent child pname gvalue)))
-(defmethod compute-virtual-slot-accessors
- ((class child-class) (slotd effective-child-slot-definition) direct-slotds)
-
- (with-slots (type) slotd
- (let ((pname (slot-definition-pname (first direct-slotds)))
- (type-number (find-type-number type)))
- (list
+(defmethod initialize-internal-slot-functions ((slotd effective-child-slot-definition))
+ (let* ((type (slot-definition-type slotd))
+ (pname (slot-definition-pname slotd))
+ (type-number (find-type-number type)))
+ (unless (slot-boundp slotd 'reader-function)
+ (setf
+ (slot-value slotd 'reader-function)
#'(lambda (object)
(with-slots (parent child) object
(with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (%container-child-get-property parent child pname gvalue)
- (unwind-protect
- (funcall
- (intern-reader-function type)
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue t))))))
+ (let ((gvalue (gvalue-new type-number)))
+ (%container-child-get-property parent child pname gvalue)
+ (unwind-protect
+ (funcall
+ (intern-reader-function type)
+ gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue t))))))))
+
+ (unless (slot-boundp slotd 'writer-function)
+ (setf
+ (slot-value slotd 'writer-function)
#'(lambda (value object)
(with-slots (parent child) object
(with-gc-disabled
- (let ((gvalue (gvalue-new type-number)))
- (funcall
- (intern-writer-function type)
- value gvalue +gvalue-value-offset+)
- (%container-child-set-property parent child pname gvalue)
- (funcall
- (intern-destroy-function type)
- gvalue +gvalue-value-offset+)
- (gvalue-free gvalue nil)
- value))))))))
+ (let ((gvalue (gvalue-new type-number)))
+ (funcall
+ (intern-writer-function type)
+ value gvalue +gvalue-value-offset+)
+ (%container-child-set-property parent child pname gvalue)
+ (funcall
+ (intern-destroy-function type)
+ gvalue +gvalue-value-offset+)
+ (gvalue-free gvalue nil)
+ value))))))
+
+ (unless (slot-boundp slotd 'boundp-function)
+ (setf
+ (slot-value slotd 'boundp-function)
+ #'(lambda (object)
+ (declare (ignore object))
+ t))))
+ (call-next-method)))
(defmethod pcl::add-reader-method ((class child-class) generic-function slot-name)
(defun default-container-child-name (container-class)
(intern (format nil "~A-CHILD" container-class)))
-(defun expand-container-type (type-number &optional slots)
- (let* ((class (type-from-number type-number))
- (super (supertype type-number))
- (child-class (default-container-child-name class))
- (expanded-child-slots
- (mapcar
- #'(lambda (param)
- (with-slots (name flags value-type documentation) param
- (let* ((slot-name (default-slot-name name))
- (slot-type (type-from-number value-type #|t|#))
- (accessor (default-slot-accessor
- child-class slot-name slot-type)))
- `(,slot-name
- :allocation :property
- :pname ,name
- ,@(cond
- ((and
- (member :writable flags)
- (member :readable flags))
- (list :accessor accessor))
- ((member :writable flags)
- (list :writer `(setf ,accessor)))
- ((member :readable flags)
- (list :reader accessor)))
- ,@(when (or
- (member :construct flags)
- (member :writable flags))
- (list :initarg (intern (string slot-name) "KEYWORD")))
- :type ,slot-type
- ,@(when documentation
- (list :documentation documentation))))))
- (query-container-class-child-properties type-number))))
+(defun expand-container-type (type &optional options)
+ (let* ((class (type-from-number type))
+ (super (supertype type))
+ (child-class (default-container-child-name class)))
`(progn
- ,(expand-gobject-type type-number slots)
- (defclass ,child-class
- (,(default-container-child-name super))
- ,expanded-child-slots
+ ,(expand-gobject-type type options)
+ (defclass ,child-class (,(default-container-child-name super))
+ ,(slot-definitions child-class
+ (query-container-class-child-properties type) nil)
(:metaclass child-class)
(:container ,class)))))
+
(register-derivable-type 'container "GtkContainer" 'expand-container-type)
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtktypes.lisp,v 1.15 2002-04-02 15:03:47 espen Exp $
+;; $Id: gtktypes.lisp,v 1.16 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
:accessor requisition-height
:initarg :height
:type int))
- (:metaclass boxed-class)
- (:alien-name "GtkTypeRequisition"))
+ (:metaclass boxed-class))
+
(defclass allocation (struct)
((x
:accessor border-bottom
:initarg :bottom
:type int))
- (:metaclass boxed-class)
- (:alien-name "GtkTypeBorder"))
-
-(defclass adjustment (%object)
- ((lower
- :allocation :alien
- :accessor adjustment-lower
- :initarg :lower
- :type single-float)
- (upper
- :allocation :alien
- :accessor adjustment-upper
- :initarg :upper
- :type single-float)
- (%value ; to get the offset right
- :allocation :alien
- :type single-float)
- (step-increment
- :allocation :alien
- :accessor adjustment-step-increment
- :initarg :step-increment
- :type single-float)
- (page-increment
- :allocation :alien
- :accessor adjustment-page-increment
- :initarg :page-increment
- :type single-float)
- (page-size
- :allocation :alien
- :accessor adjustment-page-size
- :initarg :page-size
- :type single-float)
- (value
- :allocation :virtual
- :getter "gtk_adjustment_get_value"
- :setter "gtk_adjustment_set_value"
- :accessor adjustment-value
- :initarg :value
- :type single-float))
- (:metaclass gobject-class)
- (:alien-name "GtkAdjustment"))
+ (:metaclass boxed-class))
(defclass stock-item (struct)
((id
(:metaclass proxy-class))
-
(define-types-by-introspection "Gtk"
;; Manually defined
("GtkObject" :ignore t)
("GtkRequisition" :ignore t)
("GtkBorder" :ignore t)
- ("GtkAdjustment" :ignore t)
-
+
;; Manual override
("GtkWidget"
:slots
((child-slots
- :allocation :instance
- :accessor widget-child-slots
- :type container-child)
+ :allocation :instance
+ :accessor widget-child-slots
+ :type container-child)
(parent-window
:allocation :virtual
:getter "gtk_widget_get_parent_window"
:type widget)))
("GtkPaned"
- :slot
+ :slots
((child1
:allocation :virtual
:getter paned-child1
:setter "gtk_toolbar_set_icon_size"
:accessor toolbar-icon-size
:initarg :icon-size
- :type icon-size)))
+ :type icon-size)
+ (toolbar-style
+ :allocation :property
+ :pname "toolbar-style"
+ :initarg :toolbar-style
+ :accessor toolbar-style
+ :type toolbar-style)))
("GtkNotebook"
:slots
("GtkDialog"
:slots
- ((main-area
+ ((vbox
:allocation :virtual
:getter "gtk_dialog_get_vbox"
- :reader dialog-main-area
+ :reader dialog-vbox
:type widget)
(action-area
:allocation :virtual
("GtkLayout"
:slots
((bin-window
+ :allocation :virtual
:getter "gtk_layout_get_bin_window"
:reader layout-bin-window
:type gdk:window)))
("GtkFixed"
:slots
((has-window
+ :allocation :virtual
:getter "gtk_fixed_get_has_window"
:setter "gtk_fixed_set_has_window"
:reader fixed-has-window-p
:initarg :has-window
:type boolean)))
+
+ ("GtkRange"
+ :slots
+ ((value
+ :allocation :virtual
+ :getter "gtk_range_get_value"
+ :setter "gtk_range_set_value"
+ :initarg :value
+ :accessor range-value
+ :type double-float)
+ (upper
+ :allocation :virtual
+ :getter range-upper
+ :setter (setf range-upper)
+ :initarg :upper)
+ (lower
+ :allocation :virtual
+ :getter range-lower
+ :setter (setf range-lower)
+ :initarg :lower)
+ (step-increment
+ :allocation :virtual
+ :getter range-step-increment
+ :setter (setf range-step-increment)
+ :initarg :step-increment)
+ (page-increment
+ :allocation :virtual
+ :getter range-page-increment
+ :setter (setf range-page-increment)
+ :initarg :page-increment)))
+
+ ("GtkImage"
+ :slots
+ ((file :ignore t)))
+
+ ;; Interfaces
+ ("GtkEditable"
+ :slots
+ ((editable
+ :allocation :virtual
+ :getter "gtk_editable_get_editable"
+ :setter "gtk_editable_set_editable"
+ :reader editable-editable-p
+ :initarg :editable
+ :type boolean)
+ (position
+ :allocation :virtual
+ :getter "gtk_editable_get_position"
+ :setter "gtk_editable_set_position"
+ :reader editable-position
+ :initarg :position
+ :type int)
+ (text
+ :allocation :virtual
+ :getter editable-text
+ :setter (setf editable-text)
+ :initarg text)))
+
+ ("GtkFileChooser"
+ :slots
+ ((filename
+ :allocation :virtual
+ :getter "gtk_file_chooser_get_filename"
+ :setter "gtk_file_chooser_set_filename"
+ :accessor file-chooser-filename
+ :initarg :filename
+ :type string)
+ (current-name
+ :allocation :virtual
+ :setter "gtk_file_chooser_set_current_name"
+ :accessor file-choser-current-name
+ :initarg :current-name
+ :type string)
+ (current-folder
+ :allocation :virtual
+ :setter "gtk_file_chooser_set_current_folder"
+ :setter "gtk_file_chooser_get_current_folder"
+ :accessor file-choser-current-folder
+ :initarg :current-folder
+ :type string)
+ (uri
+ :allocation :virtual
+ :getter "gtk_file_chooser_get_uri"
+ :setter "gtk_file_chooser_set_uri"
+ :accessor file-choser-uri
+ :initarg :uri
+ :type string)
+ (current-folder-uri
+ :allocation :virtual
+ :setter "gtk_file_chooser_set_current_folder_uri"
+ :setter "gtk_file_chooser_get_current_folder_uri"
+ :accessor file-choser-current-folder-uri
+ :initarg :current-folder-uri
+ :type string)))
+
;; Not needed
("GtkFundamentalType" :ignore t)
("GtkPixmap" :ignore t)
("GtkPreview" :ignore-prefix t)
("GtkTipsQuery" :ignore t)
- ("GtkOldEditable" :ignore t))
+ ("GtkOldEditable" :ignore t)
+
+ ;; What are these?
+ ("GtkFileSystemModule" :ignore t)
+ ("GtkIMModule" :ignore t)
+ ("GtkThemeEngine" :ignore t)
+
+ )
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkutils.lisp,v 1.1 2000-10-05 17:21:46 espen Exp $
+;; $Id: gtkutils.lisp,v 1.2 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
+
+(defun v-box-new (&optional homogeneous (spacing 0))
+ (make-instance 'v-box :homogeneous homogeneous :spacing spacing))
+
(defun create-button (specs &optional callback &rest args)
(destructuring-bind (label &rest initargs) (mklist specs)
(let ((button
(setf (widget-sensitive-p button) nil))
button)))
-(defun %create-toggleable-button (class label callback state args)
- (let ((button (make-instance class :label label :active state :visible t)))
+(defun button-new (label &optional callback)
+ (let ((button (make-instance 'button :label label)))
+ (when callback
+ (signal-connect button 'clicked callback))
+ button))
+
+(defun label-new (label)
+ (make-instance 'label :label label))
+
+
+
+(defun %create-toggleable-button (class label callback initstate initargs)
+ (let ((button
+ (apply #'make-instance class :label label :active initstate :visible t
+ initargs)))
(signal-connect
button 'toggled
#'(lambda ()
- (apply (funcallable callback) (toggle-button-active-p button) args)))
- (apply (funcallable callback) state args)
+ (funcall (funcallable callback) (toggle-button-active-p button))))
+ (funcall (funcallable callback) initstate)
button))
-(defun create-toggle-button (label callback &optional state &rest args)
- (%create-toggleable-button 'toggle-button label callback state args))
+(defun create-toggle-button (label callback &optional initstate &rest initargs)
+ (%create-toggleable-button 'toggle-button label callback initstate initargs))
-(defun create-check-button (label callback &optional state &rest args)
- (%create-toggleable-button 'check-button label callback state args))
+(defun create-check-button (label callback &optional initstate &rest initargs)
+ (%create-toggleable-button 'check-button label callback initstate initargs))
(defun create-radio-button-group (specs active &optional callback &rest args)
(let ((group nil)
button)))
specs)))
-(defun create-option-menu (specs active &optional callback &rest args)
+(defun create-option-menu (specs active &optional callback &rest initargs)
(let ((menu (make-instance 'menu))
(group nil)
(i 0))
(dolist (spec specs)
- (destructuring-bind (label &optional object &rest initargs) (mklist spec)
+ (destructuring-bind (label &optional item-callback) (mklist spec)
(let ((menu-item
(apply
#'make-instance 'radio-menu-item
(setq group (%radio-menu-item-get-group menu-item))
(cond
(callback
- (signal-connect
- menu-item 'activated
- #'(lambda ()
- (apply (funcallable callback) object args))))
- (object
- (signal-connect
- menu-item 'toggled
- #'(lambda ()
- (apply
- (funcallable object)
- (check-menu-item-active-p menu-item) args)))))
+ (signal-connect menu-item 'activated callback :object t))
+ (item-callback
+ (signal-connect menu-item 'toggled item-callback :object t)))
(incf i)
(menu-shell-append menu menu-item))))
(make-instance 'option-menu :history active :menu menu)))
+;; (defun sf (n)
+;; (coerce n 'single-float))
+
+(defun adjustment-new (value lower upper step-increment page-increment page-size)
+ (make-instance 'adjustment
+ :value value :lower lower :upper upper :step-increment step-increment
+ :page-increment page-increment :page-size page-size))
;; License along with this library; if not, write to the Free Software
;; Foundation, Inc., 59 Temple Place, Suite 330, Boston, MA 02111-1307 USA
-;; $Id: gtkwidget.lisp,v 1.8 2002-03-24 12:58:34 espen Exp $
+;; $Id: gtkwidget.lisp,v 1.9 2004-10-31 12:05:52 espen Exp $
(in-package "GTK")
(defmethod shared-initialize ((widget widget) names &rest initargs &key parent)
- (declare (ignore initargs names))
+ (remf initargs :parent)
(prog1
- (call-next-method)
+ (apply #'call-next-method widget names initargs)
(when parent
(let ((old-parent (widget-parent widget))
- (parent-widget (first (mklist parent)))
+ (parent (first (mklist parent)))
(args (rest (mklist parent))))
(when old-parent
(container-remove old-parent widget))
- (apply #'container-add parent-widget widget args)))))
+ (apply #'container-add parent widget args)))))
(defmethod shared-initialize :after ((widget widget) names &rest initargs
&key show-all)
~mdw / clg / commitdiff