- mcclim-cvs@common-lisp.net - mailman3.common-lisp.net

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv15525 Modified Files: ffi.lisp frame-manager.lisp gadgets.lisp port.lisp Log Message: Make demodemo ugly. * gtk-ffi.lisp (gtk_frame_new): New. * gadgets.lisp (GTK-LABEL-PANE, REALIZE-NATIVE-WIDGET, CONTAINER-PUT, CONTAINER-MOVE, CONNECT-NATIVE-SIGNALS): New class. (*USE-FRONTENT-COMPOSE-SPACE*, (COMPOSE-SPACE NATIVE-WIDGET-MIXIN)): New hack to by-pass GTK+ layouting. (COMPOSE-SPACE GTK-LABEL-PANE): Let the frontend decide. * port.lisp (CONTAINER-PUT, CONTAINER-MOVE): New generic function and default methods. (REALIZE-MIRROR, PORT-SET-MIRROR-TRANSFORMATION): Use CONTAINER-*. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:21:47 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:31:20 1.3 @@ -966,6 +966,11 @@ (has_window :int) ;gboolean ) +(defcfun "gtk_frame_new" + :pointer + (label :string) ;const gchar * + ) + (defcfun "gtk_get_current_event_time" :uint32) (defcfun "gtk_hscale_new_with_range" --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:37:14 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/19 17:31:20 1.8 @@ -96,6 +96,9 @@ (defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs) (apply #'make-instance 'gtk-list initargs)) +(defmethod make-pane-2 ((type (eql 'clim:label-pane)) &rest initargs) + (apply #'make-instance 'gtk-label-pane initargs)) + (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame application-frame)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 15:55:10 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 17:31:20 1.11 @@ -69,6 +69,8 @@ (defclass gtk-vscrollbar (native-scrollbar) ()) (defclass gtk-hscrollbar (native-scrollbar) ()) +(defclass gtk-label-pane (native-widget-mixin label-pane) + ((label-pane-fixed :accessor label-pane-fixed))) ;;;; Constructors @@ -86,6 +88,21 @@ (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) widget)) +(defmethod realize-native-widget ((sheet gtk-label-pane)) + (let ((frame (gtk_frame_new (climi::label-pane-label sheet))) + (fixed (gtk_fixed_new))) + (setf (label-pane-fixed sheet) fixed) + (gtk_container_add frame fixed) + frame)) + +(defmethod container-put ((parent gtk-label-pane) parent-widget child x y) + (declare (ignore parent-widget)) + (gtk_fixed_put (label-pane-fixed parent) child x y)) + +(defmethod container-move ((parent gtk-label-pane) parent-widget child x y) + (declare (ignore parent-widget)) + (gtk_fixed_move (label-pane-fixed parent) child x y)) + (defconstant +g-type-string+ (ash 16 2)) (defun uninstall-scroller-pane (pane) @@ -343,6 +360,10 @@ ;; no signals ) +(defmethod connect-native-signals ((sheet gtk-label-pane) widget) + ;; no signals + ) + ;;;; Event handling @@ -433,20 +454,25 @@ ;;; COMPOSE-SPACE +(defvar *use-frontend-compose-space* nil) + ;; KLUDGE: this is getting called before the sheet has been realized. (defmethod compose-space ((gadget native-widget-mixin) &key width height) (declare (ignore width height)) - (let* ((widget (native-widget gadget)) - (widgetp widget)) - (unless widgetp - (setf widget (realize-native-widget gadget))) - (prog1 - (cffi:with-foreign-object (r 'gtkrequisition) - (gtk_widget_size_request widget r) - (cffi:with-foreign-slots ((width height) r gtkrequisition) - (make-space-requirement :width width :height height))) - (unless widgetp - (gtk_widget_destroy widget))))) + (if *use-frontend-compose-space* + (let ((*use-frontend-compose-space* nil)) + (call-next-method)) + (let* ((widget (native-widget gadget)) + (widgetp widget)) + (unless widgetp + (setf widget (realize-native-widget gadget))) + (prog1 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request widget r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (make-space-requirement :width width :height height))) + (unless widgetp + (gtk_widget_destroy widget)))))) (defmethod compose-space ((gadget gtk-menu-bar) &key width height) (declare (ignore width height)) @@ -468,6 +494,11 @@ (unless widgetp (gtk_widget_destroy widget))))) +(defmethod compose-space ((gadget gtk-label-pane) &key width height) + (declare (ignore width height)) + (let ((*use-frontend-compose-space* t)) + (call-next-method))) + ;;; Vermischtes --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 15:55:11 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 17:31:20 1.11 @@ -250,6 +250,12 @@ (t +white+))) +(defmethod container-put ((parent sheet) parent-widget child x y) + (gtk_fixed_put parent-widget child x y)) + +(defmethod container-move ((parent sheet) parent-widget child x y) + (gtk_fixed_move parent-widget child x y)) + (defmethod realize-mirror ((port gtkairo-port) (sheet mirrored-sheet-mixin)) (with-gtk () (let* ((parent (sheet-mirror (sheet-parent sheet))) @@ -271,7 +277,7 @@ (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) - (gtk_fixed_put (mirror-widget parent) widget x y)) + (container-put (sheet-parent sheet) (mirror-widget parent) widget x y)) (climi::port-register-mirror (port sheet) sheet mirror) (gtk-widget-modify-bg widget (sheet-desired-color sheet)) (when (sheet-enabled-p sheet) @@ -321,7 +327,7 @@ (transform-position (climi::%sheet-mirror-transformation sheet) 0 0) (setf x (round-coordinate x)) (setf y (round-coordinate y)) - (gtk_fixed_put (mirror-widget parent) fixed x y)) + (container-put (sheet-parent sheet) (mirror-widget parent) fixed x y)) (gtk_fixed_put fixed widget 0 0) (climi::port-register-mirror (port sheet) sheet mirror) (when (sheet-enabled-p sheet) @@ -523,19 +529,21 @@ ((port gtkairo-port) (mirror mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-widget mirror)) + (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_fixed_move parent w (floor x) (floor y)))))) + (container-move parent-sheet parent w (floor x) (floor y)))))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror native-widget-mirror) mirror-transformation) (with-gtk () (let* ((w (mirror-fixed mirror)) + (parent-sheet (sheet-parent (climi::port-lookup-sheet port mirror))) (parent (cffi:foreign-slot-value w 'gtkwidget 'parent))) (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_fixed_move parent w (floor x) (floor y)))))) + (container-move parent-sheet parent w (floor x) (floor y)))))) ;;;; An und aus

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv14410 Modified Files: ffi.lisp Log Message: Sort ffi.lisp alphabetically. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 15:55:09 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:21:47 1.2 @@ -2,6 +2,38 @@ (in-package :clim-gtkairo) +(cffi:defcstruct Depth + (depth :int) ;int + (nvisuals :int) ;int + (visuals :pointer) ;Visual * + ) + +(defcenum GConnectFlags + (:G_CONNECT_AFTER 1) + :G_CONNECT_SWAPPED) + +(defcenum GdkCrossingMode + :GDK_CROSSING_NORMAL + :GDK_CROSSING_GRAB + :GDK_CROSSING_UNGRAB) + +(defcenum GdkDragAction + (:GDK_ACTION_DEFAULT 1) + :GDK_ACTION_COPY + (:GDK_ACTION_MOVE 4) + (:GDK_ACTION_LINK 8) + (:GDK_ACTION_PRIVATE 16) + (:GDK_ACTION_ASK 32)) + +(defcenum GdkDragProtocol + :GDK_DRAG_PROTO_MOTIF + :GDK_DRAG_PROTO_XDND + :GDK_DRAG_PROTO_ROOTWIN + :GDK_DRAG_PROTO_NONE + :GDK_DRAG_PROTO_WIN32_DROPFILES + :GDK_DRAG_PROTO_OLE2 + :GDK_DRAG_PROTO_LOCAL) + (defcenum GdkEventMask (:GDK_EXPOSURE_MASK 2) (:GDK_POINTER_MOTION_MASK 4) @@ -26,23 +58,6 @@ (:GDK_SCROLL_MASK 2097152) (:GDK_ALL_EVENTS_MASK 4194302)) -(defcenum GdkWindowHints - (:GDK_HINT_POS 1) - :GDK_HINT_MIN_SIZE - (:GDK_HINT_MAX_SIZE 4) - (:GDK_HINT_BASE_SIZE 8) - (:GDK_HINT_ASPECT 16) - (:GDK_HINT_RESIZE_INC 32) - (:GDK_HINT_WIN_GRAVITY 64) - (:GDK_HINT_USER_POS 128) - (:GDK_HINT_USER_SIZE 256)) - -(cffi:defcstruct Depth - (depth :int) ;int - (nvisuals :int) ;int - (visuals :pointer) ;Visual * - ) - (defcenum GdkEventType (:GDK_NOTHING -1) :GDK_DELETE @@ -82,43 +97,6 @@ :GDK_OWNER_CHANGE :GDK_GRAB_BROKEN) -(defcenum GdkModifierType - (:GDK_SHIFT_MASK 1) - :GDK_LOCK_MASK - (:GDK_CONTROL_MASK 4) - (:GDK_MOD1_MASK 8) - (:GDK_MOD2_MASK 16) - (:GDK_MOD3_MASK 32) - (:GDK_MOD4_MASK 64) - (:GDK_MOD5_MASK 128) - (:GDK_BUTTON1_MASK 256) - (:GDK_BUTTON2_MASK 512) - (:GDK_BUTTON3_MASK 1024) - (:GDK_BUTTON4_MASK 2048) - (:GDK_BUTTON5_MASK 4096) - (:GDK_RELEASE_MASK 1073741824) - (:GDK_MODIFIER_MASK 1073750015)) - -(defcenum GtkStateType - :GTK_STATE_NORMAL - :GTK_STATE_ACTIVE - :GTK_STATE_PRELIGHT - :GTK_STATE_SELECTED - :GTK_STATE_INSENSITIVE) - -(defcenum GdkDragAction - (:GDK_ACTION_DEFAULT 1) - :GDK_ACTION_COPY - (:GDK_ACTION_MOVE 4) - (:GDK_ACTION_LINK 8) - (:GDK_ACTION_PRIVATE 16) - (:GDK_ACTION_ASK 32)) - -(defcenum GdkCrossingMode - :GDK_CROSSING_NORMAL - :GDK_CROSSING_GRAB - :GDK_CROSSING_UNGRAB) - (defcenum GdkFunction :GDK_COPY :GDK_INVERT @@ -137,14 +115,29 @@ :GDK_NOR :GDK_SET) -(defcenum GdkDragProtocol - :GDK_DRAG_PROTO_MOTIF - :GDK_DRAG_PROTO_XDND - :GDK_DRAG_PROTO_ROOTWIN - :GDK_DRAG_PROTO_NONE - :GDK_DRAG_PROTO_WIN32_DROPFILES - :GDK_DRAG_PROTO_OLE2 - :GDK_DRAG_PROTO_LOCAL) +(defcenum GdkGrabStatus + :GDK_GRAB_SUCCESS + :GDK_GRAB_ALREADY_GRABBED + :GDK_GRAB_INVALID_TIME + :GDK_GRAB_NOT_VIEWABLE + :GDK_GRAB_FROZEN) + +(defcenum GdkModifierType + (:GDK_SHIFT_MASK 1) + :GDK_LOCK_MASK + (:GDK_CONTROL_MASK 4) + (:GDK_MOD1_MASK 8) + (:GDK_MOD2_MASK 16) + (:GDK_MOD3_MASK 32) + (:GDK_MOD4_MASK 64) + (:GDK_MOD5_MASK 128) + (:GDK_BUTTON1_MASK 256) + (:GDK_BUTTON2_MASK 512) + (:GDK_BUTTON3_MASK 1024) + (:GDK_BUTTON4_MASK 2048) + (:GDK_BUTTON5_MASK 4096) + (:GDK_RELEASE_MASK 1073741824) + (:GDK_MODIFIER_MASK 1073750015)) (defcenum GdkNotifyType :GDK_NOTIFY_ANCESTOR @@ -154,13 +147,16 @@ :GDK_NOTIFY_NONLINEAR_VIRTUAL :GDK_NOTIFY_UNKNOWN) -(defcenum GtkWindowType - :GTK_WINDOW_TOPLEVEL - :GTK_WINDOW_POPUP) - -(defcenum GConnectFlags - (:G_CONNECT_AFTER 1) - :G_CONNECT_SWAPPED) +(defcenum GdkWindowHints + (:GDK_HINT_POS 1) + :GDK_HINT_MIN_SIZE + (:GDK_HINT_MAX_SIZE 4) + (:GDK_HINT_BASE_SIZE 8) + (:GDK_HINT_ASPECT 16) + (:GDK_HINT_RESIZE_INC 32) + (:GDK_HINT_WIN_GRAVITY 64) + (:GDK_HINT_USER_POS 128) + (:GDK_HINT_USER_SIZE 256)) (defcenum GtkScrollType :GTK_SCROLL_NONE @@ -180,6 +176,24 @@ :GTK_SCROLL_START :GTK_SCROLL_END) +(defcenum GtkSelectionMode + :GTK_SELECTION_NONE + :GTK_SELECTION_SINGLE + :GTK_SELECTION_BROWSE + :GTK_SELECTION_MULTIPLE + (:GTK_SELECTION_EXTENDED 3)) + +(defcenum GtkStateType + :GTK_STATE_NORMAL + :GTK_STATE_ACTIVE + :GTK_STATE_PRELIGHT + :GTK_STATE_SELECTED + :GTK_STATE_INSENSITIVE) + +(defcenum GtkWindowType + :GTK_WINDOW_TOPLEVEL + :GTK_WINDOW_POPUP) + (cffi:defcstruct Screen (ext_data :pointer) ;XExtData * (display :pointer) ;struct _XDisplay * @@ -203,65 +217,69 @@ (root_input_mask :long) ;long int ) -(defcenum GdkGrabStatus - :GDK_GRAB_SUCCESS - :GDK_GRAB_ALREADY_GRABBED - :GDK_GRAB_INVALID_TIME - :GDK_GRAB_NOT_VIEWABLE - :GDK_GRAB_FROZEN) - -(defcenum GtkSelectionMode - :GTK_SELECTION_NONE - :GTK_SELECTION_SINGLE - :GTK_SELECTION_BROWSE - :GTK_SELECTION_MULTIPLE - (:GTK_SELECTION_EXTENDED 3)) - -(defcfun "gtk_check_button_new_with_label" - :pointer - (label :string) ;const gchar * +(defcfun "cairo_arc" + :void + (arg0 :pointer) ;cairo_t * + (arg1 :double) ;double + (arg2 :double) ;double + (arg3 :double) ;double + (arg4 :double) ;double + (arg5 :double) ;double ) -(defcfun "cairo_set_matrix" +(defcfun "cairo_arc_negative" :void (arg0 :pointer) ;cairo_t * - (arg1 :pointer) ;const cairo_matrix_t * + (arg1 :double) ;double + (arg2 :double) ;double + (arg3 :double) ;double + (arg4 :double) ;double + (arg5 :double) ;double ) -(defcfun "gdk_screen_get_width" - :int - (screen :pointer) ;GdkScreen * +(defcfun "cairo_clip" + :void + (arg0 :pointer) ;cairo_t * ) -(defcfun "gtk_widget_size_request" +(defcfun "cairo_copy_page" :void - (widget :pointer) ;GtkWidget * - (requisition :pointer) ;GtkRequisition * + (arg0 :pointer) ;cairo_t * ) -(defcfun "cairo_line_to" +(defcfun "cairo_create" + :pointer + (arg0 :pointer) ;cairo_surface_t * + ) + +(defcfun "cairo_curve_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double + (arg3 :double) ;double + (arg4 :double) ;double + (arg5 :double) ;double + (arg6 :double) ;double ) -(defcfun "gtk_init" +(defcfun "cairo_destroy" :void - (argc :pointer) ;int * - (argv :pointer) ;char *** + (arg0 :pointer) ;cairo_t * ) -(defcfun "gdk_window_get_root_origin" +(defcfun "cairo_fill" :void - (window :pointer) ;GdkWindow * - (x :pointer) ;gint * - (y :pointer) ;gint * + (arg0 :pointer) ;cairo_t * ) -(defcfun "cairo_reference" - :pointer +(defcfun "cairo_fill_extents" + :void (arg0 :pointer) ;cairo_t * + (arg1 :pointer) ;double * + (arg2 :pointer) ;double * + (arg3 :pointer) ;double * + (arg4 :pointer) ;double * ) (defcfun "cairo_font_extents" @@ -270,37 +288,19 @@ (arg1 :pointer) ;cairo_font_extents_t * ) -(defcfun "g_signal_connect_data" - :unsigned-long - (instance :pointer) ;gpointer - (detailed_signal :string) ;const gchar * - (c_handler :pointer) ;GCallback - (data :pointer) ;gpointer - (destroy_data :pointer) ;GClosureNotify - (connect_flags GConnectFlags)) - -(defcfun "gdk_screen_get_height_mm" - :int - (screen :pointer) ;GdkScreen * +(defcfun "cairo_font_face_status" + cairo_status_t + (arg0 :pointer) ;cairo_font_face_t * ) -(defcfun "cairo_surface_create_similar" +(defcfun "cairo_get_font_face" :pointer - (arg0 :pointer) ;cairo_surface_t * - (arg1 cairo_content_t) - (arg2 :int) ;int - (arg3 :int) ;int + (arg0 :pointer) ;cairo_t * ) -(defcfun "gtk_adjustment_set_value" - :void - (adjustment :pointer) ;GtkAdjustment * - (value :double) ;gdouble - ) - -(defcfun "cairo_pattern_reference" - :pointer - (arg0 :pointer) ;cairo_pattern_t * +(defcfun "cairo_get_target" + :pointer + (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_glyph_extents" @@ -311,151 +311,196 @@ (arg3 :pointer) ;cairo_text_extents_t * ) -(defcfun "gtk_widget_hide_all" +(defcfun "cairo_glyph_path" :void - (widget :pointer) ;GtkWidget * + (arg0 :pointer) ;cairo_t * + (arg1 :pointer) ;cairo_glyph_t * + (arg2 :int) ;int ) -(defcfun "gtk_widget_destroy" +(defcfun "cairo_identity_matrix" :void - (widget :pointer) ;GtkWidget * + (arg0 :pointer) ;cairo_t * ) -(defcfun "gtk_tree_view_new_with_model" +(defcfun "cairo_image_surface_create" :pointer - (model :pointer) ;GtkTreeModel * + (arg0 cairo_format_t) + (arg1 :int) ;int + (arg2 :int) ;int ) -(defcfun "gdk_display_flush" - :void - (display :pointer) ;GdkDisplay * +(defcfun "cairo_image_surface_create_for_data" + :pointer + (arg0 :string) ;unsigned char * + (arg1 cairo_format_t) + (arg2 :int) ;int + (arg3 :int) ;int + (arg4 :int) ;int ) -(defcfun "gtk_tree_view_column_add_attribute" - :void - (tree_column :pointer) ;GtkTreeViewColumn * - (cell_renderer :pointer) ;GtkCellRenderer * - (attribute :string) ;const gchar * - (column :int) ;gint +(defcfun "cairo_in_fill" + :int + (arg0 :pointer) ;cairo_t * + (arg1 :double) ;double + (arg2 :double) ;double ) [1529 lines skipped]

1 0

[mcclim-cvs] CVS mcclim
by dlichteblau 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25163 Modified Files: mcclim.asd Log Message: New file ffi.lisp for generated FFI code. gtk-ffi.lisp and cairo-ffi.lisp still have definitions that need to be maintained manually. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/12 22:24:27 1.34 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/19 15:55:34 1.35 @@ -355,6 +355,7 @@ (:file "package") (:file "gtk-ffi") (:file "cairo-ffi") + (:file "ffi") (:file "graft") (:file "port") (:file "event")

1 0

[mcclim-cvs] CVS mcclim/Backends/gtkairo
by dlichteblau 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv24909 Modified Files: cairo-ffi.lisp gadgets.lisp gtk-ffi.lisp medium.lisp port.lisp Added Files: ffi.lisp Log Message: New file ffi.lisp for generated FFI code. gtk-ffi.lisp and cairo-ffi.lisp still have definitions that need to be maintained manually. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/11/05 17:29:11 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/11/19 15:55:08 1.8 @@ -79,32 +79,33 @@ ;; enums +;; (can't look these up yet, why?) -(cffi:defcenum cairo_format +(cffi:defcenum cairo_format_t :argb32 :rgb24 :a8 :a1) -(cffi:defcenum cairo_operator +(cffi:defcenum cairo_operator_t :clear :src :over :in :out :atop :dest :dest_over :dest_in :dest_out :dest_atop :xor :add :saturate) -(cffi:defcenum cairo_fill_rule +(cffi:defcenum cairo_fill_rule_t :winding :even_odd) -(cffi:defcenum cairo_line_cap +(cffi:defcenum cairo_line_cap_t :butt :round :square) -(cffi:defcenum cairo_line_join +(cffi:defcenum cairo_line_join_t :miter :round :bevel) -(cffi:defcenum cairo_font_slant +(cffi:defcenum cairo_font_slant_t :normal :italic :oblique) -(cffi:defcenum cairo_font_weight +(cffi:defcenum cairo_font_weight_t :normal :bold) -(cffi:defcenum cairo_status +(cffi:defcenum cairo_status_t :success :no_memory :invalid_restore @@ -126,721 +127,19 @@ :file_not_found :invalid_dash) -(cffi:defcenum cairo_filter +(cffi:defcenum cairo_filter_t :fast :good :best :nearest :bilinear :gaussian) -(cffi:defcenum cairo_extend +(cffi:defcenum cairo_extend_t :none :repeat :reflect) - -;;; Functions for manipulating state objects - -(defcfun "cairo_create" - :pointer - (surface :pointer)) - -(defcfun "cairo_reference" - :void - (cr :pointer)) - -(defcfun "cairo_destroy" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_save" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_restore" - :void - (cr :pointer)) - -;;; XXX: Replace with cairo_current_gstate/cairo_set_gstate - -;;;(defcfun "cairo_copy" -;;; :void -;;; (destination :pointer) -;;; (source :pointer)) - -;;; Modify state - -;;;(defcfun "cairo_set_target_surface" -;;; :void -;;; (cr :pointer) -;;; (surface :pointer)) -;;; -;;;(defcfun "cairo_set_target_image" -;;; :void -;;; (cr :pointer) -;;; (data :pointer) ;(* (unsigned 8)) -;;; (format cairo_format) -;;; (width :int) -;;; (height :int) -;;; (stride :int)) - -(def-cairo-fun "cairo_set_operator" - :void - (cr :pointer) - (op cairo_operator)) - -;;; Colors - -(def-cairo-fun "cairo_set_source_rgb" - :void - (cr :pointer) - (red :double) - (green :double) - (blue :double)) - -(def-cairo-fun "cairo_set_source_rgba" - :void - (cr :pointer) - (red :double) - (green :double) - (blue :double) - (alpha :double)) - -(def-cairo-fun "cairo_set_source" - :void - (cr :pointer) - (pattern :pointer)) - -(def-cairo-fun "cairo_set_tolerance" - :void - (cr :pointer) - (tolerance :double)) - -(def-cairo-fun "cairo_set_fill_rule" - :void - (cr :pointer) - (fill_rule cairo_fill_rule)) - -(def-cairo-fun "cairo_set_line_width" - :void - (cr :pointer) - (w :double)) - -(def-cairo-fun "cairo_set_line_cap" - :void - (cr :pointer) - (line_cap cairo_line_cap)) - -(def-cairo-fun "cairo_set_line_join" - :void - (cr :pointer) - (line_join cairo_line_join)) - -(def-cairo-fun "cairo_set_dash" - :void - (cr :pointer) - (dashes :pointer) ;*double - (ndash :int) - (offset :double)) - -(def-cairo-fun "cairo_set_miter_limit" - :int - (cr :pointer) - (limit :double)) - -;;; Transformations - -(def-cairo-fun "cairo_translate" - :void - (cr :pointer) - (tx :double) - (ty :double)) - -(def-cairo-fun "cairo_scale" - :void - (cr :pointer) - (sx :double) - (sy :double)) - -(def-cairo-fun "cairo_rotate" - :void - (cr :pointer) - (angle :double)) - -(def-cairo-fun "cairo_set_matrix" - :void - (cr :pointer) - (matrix :pointer)) - -(def-cairo-fun "cairo_identity_matrix" - :void - (cr :pointer)) - -;;;(defcfun "cairo_transform_point" -;;; :void -;;; (cr :pointer) -;;; (x :pointer) ;*double -;;; (y :pointer) ;*double -;;; ) - -;;;(defcfun "cairo_transform_distance" -;;; :void -;;; (cr :pointer) -;;; (dx :pointer) ;*double -;;; (dy :pointer) ;*double -;;; ) - -;;;(defcfun "cairo_inverse_transform_point" -;;; :void -;;; (cr :pointer) -;;; (x :pointer) ;*double -;;; (y :pointer) ;*double -;;; ) -;;; -;;;(defcfun "cairo_inverse_transform_distance" -;;; :void -;;; (cr :pointer) -;;; (dx :pointer) ;*double -;;; (dy :pointer) ;*double -;;; ) - -;;; Path creation functions - -(def-cairo-fun "cairo_new_path" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_move_to" - :void - (cr :pointer) - (x :double) - (y :double)) - -(def-cairo-fun "cairo_line_to" - :void - (cr :pointer) - (x :double) - (y :double)) - -(def-cairo-fun "cairo_curve_to" - :void - (cr :pointer) - (x1 :double) - (y1 :double) - (x2 :double) - (y2 :double) - (x3 :double) - (y3 :double)) - -(def-cairo-fun "cairo_arc" - :void - (cr :pointer) - (xc :double) - (yc :double) - (radius :double) - (angle1 :double) - (angle2 :double)) - -(def-cairo-fun "cairo_arc_negative" - :void - (cr :pointer) - (xc :double) - (yc :double) - (radius :double) - (angle1 :double) - (angle2 :double)) - -(def-cairo-fun "cairo_rel_move_to" - :void - (cr :pointer) - (dx :double) - (dy :double)) - -(def-cairo-fun "cairo_rel_line_to" - :void - (cr :pointer) - (dx :double) - (dy :double)) - -(def-cairo-fun "cairo_rel_curve_to" - :void - (cr :pointer) - (dx1 :double) - (dy1 :double) - (dx2 :double) - (dy2 :double) - (dx3 :double) - (dy3 :double)) - -(def-cairo-fun "cairo_rectangle" - :void - (cr :pointer) - (x :double) - (y :double) - (w :double) - (h :double)) - -(def-cairo-fun "cairo_close_path" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_stroke" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_fill" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_copy_page" - :void - (cr :pointer)) - -(def-cairo-fun "cairo_show_page" - :void - (cr :pointer)) - -;;; Insideness testing - -(def-cairo-fun "cairo_in_stroke" - :int - (cr :pointer) - (x :double) - (y :double)) - -(def-cairo-fun "cairo_in_fill" - :int - (cr :pointer) - (x :double) - (y :double)) - -;;; Rectangular extents - -(def-cairo-fun "cairo_stroke_extents" - :void - (cr :pointer) - (x1 :pointer) ;*double - (y1 :pointer) ;*double - (x2 :pointer) ;*double - (y2 :pointer) ;*double - ) - -(def-cairo-fun "cairo_fill_extents" - :void - (cr :pointer) - (x1 :pointer) ;*double - (y1 :pointer) ;*double - (x2 :pointer) ;*double - (y2 :pointer) ;*double - ) - -(def-cairo-fun "cairo_reset_clip" - :void - (cr :pointer)) - -;; Note: cairo_clip does not consume the current path -(def-cairo-fun "cairo_clip" - :void - (cr :pointer)) - -;;; Font/Text functions - - -;; This interface is for dealing with text as text, not caring about the -;; font object inside the the cairo_t. - -(def-cairo-fun "cairo_select_font_face" - :void - (cr :pointer) - (family :string) - (slant cairo_font_slant) - (weight cairo_font_weight)) - -(def-cairo-fun "cairo_set_font_size" - :void - (cr :pointer) - (size :double)) - -;;;(defcfun "cairo_transform_font" -;;; :void -;;; (cr :pointer) -;;; (matrix :pointer)) - -(def-cairo-fun "cairo_show_text" - :void - (cr :pointer) - (string :string)) - -(def-cairo-fun "cairo_show_glyphs" - :void - (cr :pointer) - (glyphs :pointer) - (num_glyphs :int)) - -;;;(def-cairo-fun "cairo_current_font" -;;; :pointer -;;; (cr :pointer)) -;;; -(def-cairo-fun "cairo_font_extents" [378 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 20:37:14 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 15:55:10 1.10 @@ -136,8 +136,8 @@ (gtk_tree_selection_set_mode (list-pane-selection sheet) (if (eq (climi::list-pane-mode sheet) :exclusive) - :browse - :multiple)) + :GTK_SELECTION_BROWSE + :GTK_SELECTION_MULTIPLE)) (gtk-list-reset-selection sheet) (let ((ancestor (and (sheet-parent sheet) (sheet-parent (sheet-parent sheet)))) @@ -369,20 +369,20 @@ (defmethod handle-event ((pane native-scrollbar) (event scrollbar-change-value-event)) (case (event-scroll-type event) - (:jump + (:gtk_scroll_jump (let ((value (clamp (gadget-min-value pane) (event-value event) (gadget-max-value pane)))) (setf (gadget-value pane :invoke-callback nil) value) (drag-callback pane (gadget-client pane) (gadget-id pane) value))) - (:step_backward + (:gtk_scroll_step_backward (scroll-up-line-callback pane (gadget-client pane) (gadget-id pane))) - (:step_forward + (:gtk_scroll_step_forward (scroll-down-line-callback pane (gadget-client pane) (gadget-id pane))) - (:page_backward + (:gtk_scroll_page_backward (scroll-up-page-callback pane (gadget-client pane) (gadget-id pane))) - (:page_forward + (:gtk_scroll_page_forward (scroll-down-page-callback pane (gadget-client pane) (gadget-id pane))))) (defmethod handle-event --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 20:12:19 1.14 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/19 15:55:10 1.15 @@ -43,9 +43,21 @@ (cffi:load-foreign-library "libgtk-win32-2.0-0.dll")) (defmacro defcfun (name rtype &rest argtypes) - `(cffi:defcfun (,name ,(intern (string-upcase name) :clim-gtkairo)) - ,rtype - ,@argtypes)) + (if (and (eq rtype 'cairo_status_t) + (not (equal name "cairo_status"))) + `(def-cairo-fun ,name ,rtype ,@argtypes) + `(cffi:defcfun (,name ,(intern (string-upcase name) :clim-gtkairo)) + ,rtype + ,@argtypes))) + +(defmacro defcenum (name &rest values) + `(progn + (cffi:defcenum ,name ,@values) + ,@(loop + for pair in values + for key = (if (listp pair) (car pair) pair) + collect `(defconstant ,(intern (symbol-name key) :clim-gtkairo) + (cffi:foreign-enum-value ',name ,key))))) ;;; Here's a hack to wait on GTK's Xlib Display's socket file descriptor @@ -131,20 +143,6 @@ (gdk_threads_leave))))) -;;; Error handling: - -(defcfun "gdk_error_trap_push" :void) -(defcfun "gdk_error_trap_pop" :int) - -#-(or win32 mswindows windows) -(cffi:defcfun "XGetErrorText" - :void - (display :pointer) - (code :int) - (buf :pointer) - (length :int)) - - ;;; GROVELME ;; must be a separate structure definition in order for padding on AMD64 @@ -301,133 +299,10 @@ (data0 :uint64) (data1 :uint64)) -(cffi:defcenum gdkfunction - :copy :invert :xor :clear :and :and_reverse :and_invert :noop :or :equiv - :or_reverse :copy_invert :or_invert :nand :nor :set) - -(cffi:defcenum gtkscrolltype - :none :jump :step_backward :step_forward :page_backward :page_forward - :step_up :step_down :page_up :page_down :step_left :step_right :page_left - :page_right :start :end) - -(cffi:defcenum gtkselectionmode - :none :single :browse :multiple) - - -;;; GTK functions (defconstant GTK_WINDOW_TOPLEVEL 0) (defconstant GTK_WINDOW_POPUP 1) -(defcfun "gtk_init" - :void - (argc :int) - (argv :pointer)) - -(defcfun "gtk_events_pending" - :int) - -(defcfun "gtk_main_iteration_do" - :void - (block :int)) - -(defcfun "gtk_window_new" - :pointer - (type :int)) - -(defcfun "gtk_widget_destroy" - :void - (window :pointer)) - -(defcfun "gtk_widget_show_all" - :void - (widget :pointer)) - -(defcfun "gtk_widget_hide_all" - :void - (widget :pointer)) - -(defcfun "gtk_widget_show" - :void - (widget :pointer)) - -(defcfun "gtk_widget_hide" - :void - (widget :pointer)) - -(defcfun "gtk_window_resize" - :void - (window :pointer) - (width :int) - (height :int)) - -(defcfun "gtk_window_move" - :void - (window :pointer) - (x :int) - (y :int)) - -(defcfun "gtk_drawing_area_new" - :pointer) - -(defcfun "gtk_widget_set_size_request" - :void - (widget :pointer) - (width :int) - (height :int)) - -(defcfun "gtk_widget_get_size_request" - :void - (widget :pointer) - (width :pointer) - (height :pointer)) - -(defcfun "gtk_widget_size_request" - :void - (widget :pointer) - (requisition :pointer)) - -(defcfun "gtk_container_add" - :void - (parent :pointer) - (child :pointer)) - -(defcfun "gdk_cairo_create" - :pointer - (gdk-window :pointer)) - -(defcfun "gtk_fixed_new" - :pointer - ) - -(defcfun "gtk_fixed_put" - :void - (fixed :pointer) - (child :pointer) - (x :int) - (y :int)) - -(defcfun "gtk_fixed_move" - :void - (fixed :pointer) - (child :pointer) - (x :int) - (y :int)) - -(defcfun "gtk_fixed_set_has_window" - :void - (fixed :pointer) - (windowp :int)) - -(defcfun "g_signal_connect_data" - :void - (object :pointer) - (event :string) - (callback :pointer) - (data :pointer) - (destroy_data :pointer) - (flags :int)) - (defun g-signal-connect (object event callback &optional data) (g_signal_connect_data object event @@ -436,552 +311,14 @@ (cffi:null-pointer) 0)) -(defcfun "gtk_widget_add_events" - :void - (widget :pointer) - (events :int)) - -(defcfun "gtk_widget_set_events" - :void - (widget :pointer) - (events :int)) - -(defcfun "gtk_widget_get_events" - :int - (widget :pointer)) - -(defcfun "gtk_widget_grab_focus" - :void - (widget :pointer)) - -(defcfun "gtk_widget_set_double_buffered" - :void - (widget :pointer) - (enable :int)) - -(defcfun "gdk_display_flush" - :void - (display :pointer)) - -(defcfun "gdk_display_get_default" - :pointer) - -(defcfun "gdk_display_get_pointer" - :void - (display :pointer) - (screen :pointer) - (x :pointer) - (y :pointer) - (mask :pointer)) - -(defcfun "gtk_widget_get_pointer" - :void - (widget :pointer) - (x :pointer) - (y :pointer)) - -(defcfun "gdk_screen_get_default" - :pointer - ) - -(defcfun "gdk_screen_get_height" - :int - (screen :pointer)) - -(defcfun "gdk_screen_get_width" - :int - (screen :pointer)) - -(defcfun "gdk_screen_get_height_mm" - :int - (screen :pointer)) - -(defcfun "gdk_screen_get_width_mm" - :int - (screen :pointer)) - -(defcfun "gdk_pointer_grab" - :int - (gdkwindow :pointer) - (owner_events :int) - (event_mask :int) - (confine_to :pointer) - (cursor :pointer) - (time :uint32)) - -(defcfun "gdk_pointer_ungrab" - :void - (time :uint32)) - -(defcfun "gdk_threads_enter" - :void) - -(defcfun "gdk_threads_leave" - :void) - -(defcfun "gdk_threads_init" - :void) - -(defcfun "g_thread_init" - :void - (fns :pointer)) - -(defcfun "gdk_flush" - :void) - -(defcfun "gdk_window_begin_paint_rect" - :void - (window :pointer) - (rect :pointer)) - -(defcfun "gdk_window_end_paint" - :void - (window :pointer)) - -(defcfun "gdk_window_get_root_origin" - :void - (window :pointer) - (x :pointer) - (y :pointer)) - -(defcfun "gtk_widget_modify_bg" - :void - (widget :pointer) - (state :int) - (color :pointer)) - -(defcfun "gtk_window_set_default_size" - :void - (window :pointer) - (width :int) - (height :int)) - -(defcfun "gtk_widget_size_allocate" - :void - (widget :pointer) - (allocation :pointer)) - -(defcfun "gtk_widget_queue_resize" - :void - (widget :pointer)) - -(defcfun "gtk_window_set_geometry_hints" - :void - (window :pointer) - (widget :pointer) - (geometry :pointer) - (mask :int)) - -(defcfun "gdk_screen_get_root_window" - :pointer - (screen :pointer)) - -(defcfun "gdk_pixmap_new" - :pointer - (drawable :pointer) - (width :int) - (height :int) - (depth :int)) - -(defcfun "gdk_drawable_unref" - :void - (drawable :pointer)) - -(defcfun "gdk_drawable_get_depth" - :int - (drawable :pointer)) - -(defcfun "gdk_gc_new" - :pointer - (drawable :pointer)) - -(defcfun "gdk_gc_unref" - :void - (drawable :pointer)) - -(defcfun "gdk_gc_set_function" - :void - (gc :pointer) - (function gdkfunction)) - -(defcfun "gdk_draw_drawable" - :void - (drawable :pointer) - (gc :pointer) - (src-drawable :pointer) - (xsrc :int) - (ysrc :int) - (xdest :int) - (ydest :int) - (width :int) - (height :int)) - -(defcfun "gdk_draw_rectangle" - :void - (drawable :pointer) - (gc :pointer) - (filled :int) - (x :int) - (y :int) - (width :int) - (height :int)) - -(defcfun "gdk_gc_set_rgb_fg_color" - :void - (gc :pointer) - (color :pointer)) - -(defcfun "gtk_button_new" - :pointer - ) - -(defcfun "gtk_button_new_with_label" - :pointer - (label :string)) - -(defcfun "gtk_menu_item_new_with_label" - :pointer - (label :string)) - -(defcfun "gtk_menu_bar_new" - :pointer - ) - -(defcfun "gtk_menu_shell_append" - :void - (menu :pointer) [379 lines skipped] --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 21:23:12 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/19 15:55:11 1.12 @@ -224,7 +224,7 @@ (cairo_surface_flush to-surface) (let ((gc (gdk_gc_new to-drawable)) (region (flipping-region medium))) - (gdk_gc_set_function gc :xor) + (gdk_gc_set_function gc :GDK_XOR) (gdk_draw_drawable to-drawable gc from-drawable (floor (bounding-rectangle-min-x region)) (floor (bounding-rectangle-min-y region)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/12 11:45:21 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/19 15:55:11 1.10 @@ -80,7 +80,7 @@ (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten - (gtk_init 0 (cffi:null-pointer)) + (gtk_init (cffi:null-pointer) (cffi:null-pointer)) (let ((cr (gdk_cairo_create (gdk_screen_get_root_window (gdk_screen_get_default))))) (setf (metrik-medium port) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 15:55:12 NONE +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 15:55:12 1.1 ;;; -*- Mode: Lisp; -*- (in-package :clim-gtkairo) (defcenum GdkEventMask (:GDK_EXPOSURE_MASK 2) (:GDK_POINTER_MOTION_MASK 4) (:GDK_POINTER_MOTION_HINT_MASK 8) (:GDK_BUTTON_MOTION_MASK 16) (:GDK_BUTTON1_MOTION_MASK 32) (:GDK_BUTTON2_MOTION_MASK 64) (:GDK_BUTTON3_MOTION_MASK 128) (:GDK_BUTTON_PRESS_MASK 256) (:GDK_BUTTON_RELEASE_MASK 512) (:GDK_KEY_PRESS_MASK 1024) (:GDK_KEY_RELEASE_MASK 2048) (:GDK_ENTER_NOTIFY_MASK 4096) (:GDK_LEAVE_NOTIFY_MASK 8192) (:GDK_FOCUS_CHANGE_MASK 16384) (:GDK_STRUCTURE_MASK 32768) (:GDK_PROPERTY_CHANGE_MASK 65536) (:GDK_VISIBILITY_NOTIFY_MASK 131072) (:GDK_PROXIMITY_IN_MASK 262144) (:GDK_PROXIMITY_OUT_MASK 524288) (:GDK_SUBSTRUCTURE_MASK 1048576) (:GDK_SCROLL_MASK 2097152) (:GDK_ALL_EVENTS_MASK 4194302)) (defcenum GdkWindowHints (:GDK_HINT_POS 1) :GDK_HINT_MIN_SIZE (:GDK_HINT_MAX_SIZE 4) (:GDK_HINT_BASE_SIZE 8) (:GDK_HINT_ASPECT 16) (:GDK_HINT_RESIZE_INC 32) (:GDK_HINT_WIN_GRAVITY 64) (:GDK_HINT_USER_POS 128) (:GDK_HINT_USER_SIZE 256)) (cffi:defcstruct Depth (depth :int) ;int (nvisuals :int) ;int (visuals :pointer) ;Visual * ) (defcenum GdkEventType (:GDK_NOTHING -1) :GDK_DELETE :GDK_DESTROY :GDK_EXPOSE :GDK_MOTION_NOTIFY :GDK_BUTTON_PRESS :GDK_2BUTTON_PRESS :GDK_3BUTTON_PRESS :GDK_BUTTON_RELEASE :GDK_KEY_PRESS :GDK_KEY_RELEASE :GDK_ENTER_NOTIFY :GDK_LEAVE_NOTIFY :GDK_FOCUS_CHANGE :GDK_CONFIGURE :GDK_MAP :GDK_UNMAP :GDK_PROPERTY_NOTIFY :GDK_SELECTION_CLEAR :GDK_SELECTION_REQUEST :GDK_SELECTION_NOTIFY :GDK_PROXIMITY_IN :GDK_PROXIMITY_OUT :GDK_DRAG_ENTER :GDK_DRAG_LEAVE :GDK_DRAG_MOTION :GDK_DRAG_STATUS :GDK_DROP_START :GDK_DROP_FINISHED :GDK_CLIENT_EVENT :GDK_VISIBILITY_NOTIFY :GDK_NO_EXPOSE :GDK_SCROLL :GDK_WINDOW_STATE :GDK_SETTING :GDK_OWNER_CHANGE :GDK_GRAB_BROKEN) (defcenum GdkModifierType (:GDK_SHIFT_MASK 1) :GDK_LOCK_MASK (:GDK_CONTROL_MASK 4) (:GDK_MOD1_MASK 8) (:GDK_MOD2_MASK 16) (:GDK_MOD3_MASK 32) (:GDK_MOD4_MASK 64) (:GDK_MOD5_MASK 128) (:GDK_BUTTON1_MASK 256) (:GDK_BUTTON2_MASK 512) (:GDK_BUTTON3_MASK 1024) (:GDK_BUTTON4_MASK 2048) (:GDK_BUTTON5_MASK 4096) (:GDK_RELEASE_MASK 1073741824) (:GDK_MODIFIER_MASK 1073750015)) (defcenum GtkStateType :GTK_STATE_NORMAL :GTK_STATE_ACTIVE :GTK_STATE_PRELIGHT :GTK_STATE_SELECTED :GTK_STATE_INSENSITIVE) (defcenum GdkDragAction (:GDK_ACTION_DEFAULT 1) :GDK_ACTION_COPY (:GDK_ACTION_MOVE 4) (:GDK_ACTION_LINK 8) (:GDK_ACTION_PRIVATE 16) (:GDK_ACTION_ASK 32)) (defcenum GdkCrossingMode :GDK_CROSSING_NORMAL :GDK_CROSSING_GRAB :GDK_CROSSING_UNGRAB) (defcenum GdkFunction :GDK_COPY :GDK_INVERT :GDK_XOR :GDK_CLEAR :GDK_AND :GDK_AND_REVERSE :GDK_AND_INVERT :GDK_NOOP :GDK_OR :GDK_EQUIV :GDK_OR_REVERSE :GDK_COPY_INVERT :GDK_OR_INVERT :GDK_NAND :GDK_NOR :GDK_SET) (defcenum GdkDragProtocol :GDK_DRAG_PROTO_MOTIF :GDK_DRAG_PROTO_XDND :GDK_DRAG_PROTO_ROOTWIN :GDK_DRAG_PROTO_NONE :GDK_DRAG_PROTO_WIN32_DROPFILES :GDK_DRAG_PROTO_OLE2 :GDK_DRAG_PROTO_LOCAL) (defcenum GdkNotifyType :GDK_NOTIFY_ANCESTOR :GDK_NOTIFY_VIRTUAL :GDK_NOTIFY_INFERIOR :GDK_NOTIFY_NONLINEAR :GDK_NOTIFY_NONLINEAR_VIRTUAL :GDK_NOTIFY_UNKNOWN) (defcenum GtkWindowType :GTK_WINDOW_TOPLEVEL :GTK_WINDOW_POPUP) (defcenum GConnectFlags (:G_CONNECT_AFTER 1) :G_CONNECT_SWAPPED) (defcenum GtkScrollType :GTK_SCROLL_NONE :GTK_SCROLL_JUMP :GTK_SCROLL_STEP_BACKWARD :GTK_SCROLL_STEP_FORWARD :GTK_SCROLL_PAGE_BACKWARD :GTK_SCROLL_PAGE_FORWARD :GTK_SCROLL_STEP_UP :GTK_SCROLL_STEP_DOWN :GTK_SCROLL_PAGE_UP :GTK_SCROLL_PAGE_DOWN :GTK_SCROLL_STEP_LEFT :GTK_SCROLL_STEP_RIGHT :GTK_SCROLL_PAGE_LEFT :GTK_SCROLL_PAGE_RIGHT :GTK_SCROLL_START :GTK_SCROLL_END) (cffi:defcstruct Screen (ext_data :pointer) ;XExtData * (display :pointer) ;struct _XDisplay * (root :unsigned-long) ;Window (width :int) ;int (height :int) ;int (mwidth :int) ;int (mheight :int) ;int (ndepths :int) ;int (depths :pointer) ;Depth * (root_depth :int) ;int (root_visual :pointer) ;Visual * (default_gc :pointer) ;GC (cmap :unsigned-long) ;Colormap (white_pixel :unsigned-long) ;long unsigned int (black_pixel :unsigned-long) ;long unsigned int (max_maps :int) ;int (min_maps :int) ;int (backing_store :int) ;int (save_unders :int) ;int (root_input_mask :long) ;long int ) (defcenum GdkGrabStatus :GDK_GRAB_SUCCESS :GDK_GRAB_ALREADY_GRABBED :GDK_GRAB_INVALID_TIME :GDK_GRAB_NOT_VIEWABLE :GDK_GRAB_FROZEN) (defcenum GtkSelectionMode :GTK_SELECTION_NONE :GTK_SELECTION_SINGLE :GTK_SELECTION_BROWSE :GTK_SELECTION_MULTIPLE (:GTK_SELECTION_EXTENDED 3)) (defcfun "gtk_check_button_new_with_label" :pointer (label :string) ;const gchar * ) (defcfun "cairo_set_matrix" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;const cairo_matrix_t * ) (defcfun "gdk_screen_get_width" :int (screen :pointer) ;GdkScreen * ) (defcfun "gtk_widget_size_request" :void (widget :pointer) ;GtkWidget * (requisition :pointer) ;GtkRequisition * ) (defcfun "cairo_line_to" :void (arg0 :pointer) ;cairo_t * (arg1 :double) ;double (arg2 :double) ;double ) (defcfun "gtk_init" :void (argc :pointer) ;int * (argv :pointer) ;char *** ) (defcfun "gdk_window_get_root_origin" :void (window :pointer) ;GdkWindow * (x :pointer) ;gint * (y :pointer) ;gint * ) (defcfun "cairo_reference" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "cairo_font_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_font_extents_t * ) (defcfun "g_signal_connect_data" :unsigned-long (instance :pointer) ;gpointer (detailed_signal :string) ;const gchar * (c_handler :pointer) ;GCallback (data :pointer) ;gpointer (destroy_data :pointer) ;GClosureNotify (connect_flags GConnectFlags)) (defcfun "gdk_screen_get_height_mm" :int (screen :pointer) ;GdkScreen * ) (defcfun "cairo_surface_create_similar" :pointer (arg0 :pointer) ;cairo_surface_t * (arg1 cairo_content_t) (arg2 :int) ;int (arg3 :int) ;int ) (defcfun "gtk_adjustment_set_value" :void (adjustment :pointer) ;GtkAdjustment * (value :double) ;gdouble ) (defcfun "cairo_pattern_reference" :pointer (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "cairo_glyph_extents" :void (arg0 :pointer) ;cairo_t * (arg1 :pointer) ;cairo_glyph_t * (arg2 :int) ;int (arg3 :pointer) ;cairo_text_extents_t * ) (defcfun "gtk_widget_hide_all" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_widget_destroy" :void (widget :pointer) ;GtkWidget * ) (defcfun "gtk_tree_view_new_with_model" :pointer (model :pointer) ;GtkTreeModel * ) (defcfun "gdk_display_flush" :void (display :pointer) ;GdkDisplay * ) (defcfun "gtk_tree_view_column_add_attribute" :void (tree_column :pointer) ;GtkTreeViewColumn * (cell_renderer :pointer) ;GtkCellRenderer * (attribute :string) ;const gchar * (column :int) ;gint ) (defcfun "cairo_font_face_status" cairo_status_t (arg0 :pointer) ;cairo_font_face_t * ) (defcfun "g_value_set_string" :void (value :pointer) ;GValue * (v_string :string) ;const gchar * ) (defcfun "cairo_get_target" :pointer (arg0 :pointer) ;cairo_t * ) (defcfun "gtk_window_resize" :void (window :pointer) ;GtkWindow * (width :int) ;gint (height :int) ;gint ) (defcfun "gtk_widget_modify_bg" :void (widget :pointer) ;GtkWidget * (state GtkStateType) (color :pointer) ;const GdkColor * ) (defcfun "cairo_pattern_destroy" :void (arg0 :pointer) ;cairo_pattern_t * ) (defcfun "gtk_list_store_newv" :pointer (n_columns :int) ;gint (types :pointer) ;GType * ) (defcfun "gtk_scale_set_digits" :void (scale :pointer) ;GtkScale * (digits :int) ;gint ) (defcfun "gdk_gc_set_rgb_fg_color" [937 lines skipped]

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by crhodes 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv21288/Apps/Listener Modified Files: listener.lisp Log Message: Whoops. TYPE is shadowed in the accept method for sequence. How horrible. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 12:30:56 1.28 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/19 15:31:43 1.29 @@ -175,16 +175,21 @@ (define-presentation-method accept :around ((type sequence) stream (view listener-view) &key default default-type) - (let* ((token (read-token stream)) - (result (handler-case (read-from-string token) - (error (c) - (declare (ignore c)) - (simple-parse-error - "Error parsing ~S for presentation type ~S" - token type))))) - (if (presentation-typep result type) - (values result type) - (input-not-of-required-type result type)))) + ;; oh, my word. although TYPE here might look like it's bound to + ;; the presentation type itself, in fact it is bound to the + ;; parameter of the SEQUENCE presentation type. We need the + ;; presentation type itself, so we reconstruct it. + (let ((ptype (list 'sequence type))) + (let* ((token (read-token stream)) + (result (handler-case (read-from-string token) + (error (c) + (declare (ignore c)) + (simple-parse-error + "Error parsing ~S for presentation type ~S" + token ptype))))) + (if (presentation-typep result ptype) + (values result ptype) + (input-not-of-required-type result ptype))))) ;;; Listener interactor stream. If only STREAM-PRESENT were ;;; specializable on the VIEW argument, this wouldn't be necessary.

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 19 Nov '06

19 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8661/Drei Modified Files: drei-redisplay.lisp drei.lisp kill-ring.lisp packages.lisp undo.lisp Log Message: Docstring additions and added some undo-related symbols to the export-list for the DREI package. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/17 20:18:56 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/19 11:39:44 1.5 @@ -47,8 +47,26 @@ ;;; The basic Drei redisplay functions: (defgeneric display-drei-contents (stream drei syntax) - (:documentation "Display the contents of the Drei instance -`drei', which is in the syntax `syntax', to `stream'.") + (:documentation "The purpose of this function is to display the +buffer contents of a Drei instance to some output +surface. `Stream' is the CLIM output stream that redisplay should +be performed on, `drei' is the Drei instance that is being +redisplayed, and `syntax' is the syntax object of the buffer in +`drei'. Methods defined for this generic function can draw +whatever they want, but they should not assume that they are the +only user of `stream', unless the `stream' argument has been +specialized to some application-specific pane class that can +guarantee this. For example, when accepting multiple values using +the `accepting-values' macro, several Drei instances will be +displayed simultaneously on the same stream. It is permitted to +only specialise `stream' on `clim-stream-pane' and not +`extended-output-stream'. When writing methods for this function, +be aware that you cannot assume that the buffer will contain only +characters, and that any subsequence of the buffer is coercable +to a string. Drei buffers can contain arbitrary objects, and +redisplay methods are required to handle this (though they are +not required to handle it nicely, they can just ignore the +object, or display the `princ'ed representation.)") (:method :around ((stream extended-output-stream) (drei drei) (syntax syntax)) (letf (((stream-default-view stream) (view drei))) (call-next-method)))) @@ -64,7 +82,26 @@ (setf (output-record-position record) (stream-cursor-position stream)))) (defgeneric display-drei-cursor (stream drei cursor syntax) - (:documentation "Display the given cursor to `stream'.") + (:documentation "The purpose of this function is to display a +visible indication of a cursor of a Drei instance to some output +surface. `Stream' is the CLIM output stream that drawing should +be performed on, `drei' is the Drei instance that is being +redisplayed, `cursor' is the cursor object to be displayed (a +subclass of `drei-cursor') and `syntax' is the syntax object of +the buffer in `drei'}. Methods on this generic function can draw +whatever they want, but they should not assume that they are the +only user of `stream', unless the `stream' argument has been +specialized to some application-specific pane class that can +guarantee this. It is permitted to only specialise `stream' on +`clim-stream-pane' and not `extended-output-stream'. It is +recommended to use the function `offset-to-screen-position' to +determine where to draw the visual representation for the +cursor. It is also recommended to use the ink specified by +`cursor' to perform the drawing, if applicable. This method will +only be called by the Drei redisplay engine when the cursor is +active and the buffer position it refers to is on display - +therefore, `offset-to-screen-position' is *guaranteed* to not +return NIL or T.") (:method :around ((stream extended-output-stream) (drei drei) (cursor drei-cursor) (syntax syntax)) (when (visible cursor drei) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/18 20:59:28 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/19 11:39:45 1.8 @@ -129,24 +129,67 @@ ;;; Undo (defclass undo-mixin () - ((tree :initform (make-instance 'standard-undo-tree) :reader undo-tree) - (undo-accumulate :initform '() :accessor undo-accumulate) - (performing-undo :initform nil :accessor performing-undo))) + ((tree :initform (make-instance 'standard-undo-tree) + :reader undo-tree + :documentation "Returns the undo-tree of the buffer.") + (undo-accumulate :initform '() + :accessor undo-accumulate + :documentation "The list returned by this +function is initially NIL (the empty list). The :before methods +on `insert-buffer-object', `insert-buffer-sequence', and +`delete-buffer-range' push undo records on to this list.") + (performing-undo :initform nil + :accessor performing-undo + :documentation "This is initially NIL. +The :before methods on `insert-buffer-object', +`insert-buffer-sequence', and `delete-buffer-range' push undo +records onto the undo accumulator only if this slot is NIL so +that no undo information is added as a result of an undo +operation.")) + (:documentation "This is a mixin class that buffer classes can +inherit from. It contains an undo tree, an undo accumulator and a +flag specifyng whether or not it is currently performing +undo. The undo tree and undo accumulators are initially empty.")) (defclass drei-undo-record (standard-undo-record) - ((buffer :initarg :buffer))) + ((buffer :initarg :buffer + :documentation "The buffer to which the record +belongs.")) + (:documentation "A base class for all output records in +Drei.")) (defclass simple-undo-record (drei-undo-record) - ((offset :initarg :offset :reader undo-offset))) + ((offset :initarg :offset + :reader undo-offset + :documentation "The offset that determines the +position at which the undo operation is to be executed.")) + (:documentation "A base class for output records that modify +buffer contents at a specific offset.")) (defclass insert-record (simple-undo-record) - ((objects :initarg :objects))) + ((objects :initarg :objects + :documentation "The sequence of objects that are to +be inserted whenever flip-undo-record is called on an instance of +insert-record.")) + (:documentation "Whenever objects are deleted, the sequence of +objects is stored in an insert record containing a mark.")) (defclass delete-record (simple-undo-record) - ((length :initarg :length))) + ((length :initarg :length + :documentation "The length of the sequence of objects +to be deleted whenever `flip-undo-record' is called on an +instance of `delete-record'.")) + (:documentation "Whenever objects are inserted, a +`delete-record' containing a mark is created and added to the +undo tree.")) (defclass compound-record (drei-undo-record) - ((records :initform '() :initarg :records))) + ((records :initform '() + :initarg :records + :documentation "The undo records contained by this +compound record.")) + (:documentation "This record simply contains a list of other +records.")) (defmethod print-object ((object delete-record) stream) (with-slots (offset length) object @@ -181,12 +224,16 @@ (undo-accumulate buffer)))) (defmacro with-undo ((get-buffers-exp) &body body) - "Evaluate `body', registering any changes to buffer contents in -the undo memory for the respective buffer, permitting individual -undo for each buffer. `get-buffers-exp' should be a form, that -will be evaluated whenever a complete list of buffers is -needed (to set up all buffers to prepare for undo, and to check -them all for changes after `body' has run)." + "This macro executes the forms of `body', registering changes +made to the list of buffers retrieved by evaluating +`get-buffers-exp'. When `body' has run, for each buffer it will +call `add-undo' with an undo record and the undo tree of the +buffer. If the changes done by `body' to the buffer has resulted +in only a single undo record, it is passed as is to `add-undo'. +If it contains several undo records, a compound undo record is +constructed out of the list and passed to `add-undo'. Finally, +if the buffer has no undo records, `add-undo' is not called at +all." (with-gensyms (buffer) `(progn (dolist (,buffer ,get-buffers-exp) --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/19 11:39:45 1.2 @@ -26,12 +26,21 @@ (defclass kill-ring () ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol - :initarg :max-size) + :initarg :max-size + :documentation "The limitation placed upon the +number of elements held by the kill ring. Once the maximum size +has been reached, older entries must first be removed before new +ones can be added. When altered, any surplus elements will be +silently dropped.") (cursorchain :type standard-cursorchain :accessor kill-ring-chain - :initform (make-instance 'standard-cursorchain)) + :initform (make-instance 'standard-cursorchain) + :documentation "The cursorchain associated with +the kill ring.") (yankpoint :type left-sticky-flexicursor - :accessor kill-ring-cursor) + :accessor kill-ring-cursor + :documentation "The flexicursor associated with +the kill ring.") (append-next-p :type boolean :initform nil :accessor append-next-p)) (:documentation "A class for all kill rings")) @@ -51,38 +60,40 @@ (setf yankpoint (make-instance 'left-sticky-flexicursor :chain cursorchain)))) (defgeneric kill-ring-length (kr) - (:documentation "Returns the current length of the kill ring")) + (:documentation "Returns the current length of the kill-ring. +Note this is different than `kill-ring-max-size'.")) (defgeneric kill-ring-max-size (kr) - (:documentation "Returns the value of a kill ring's maximum size")) + (:documentation "Returns the value of the kill ring's maximum +size")) (defgeneric (setf kill-ring-max-size) (kr size) - (:documentation "Alters the maximum size of a kill ring, even + (:documentation "Alters the maximum size of the kill ring, even if it means dropping elements to do so.")) (defgeneric reset-yank-position (kr) - (:documentation "Moves the current yank point back to the start of - of kill ring position")) + (:documentation "Moves the current yank point back to the start +of of kill ring position")) (defgeneric rotate-yank-position (kr &optional times) - (:documentation "Moves the yank point associated with a kill-ring - one or times many positions away from the start - of ring position. If times is greater than the - current length then the cursor will wrap to the - start of ring position and continue rotating.")) + (:documentation "Moves the yank point associated with a +kill-ring one or times many positions away from the start of ring +position. If times is greater than the current length then the +cursor will wrap to the start of ring position and continue +rotating.")) (defgeneric kill-ring-standard-push (kr vector) - (:documentation "Pushes a vector of objects onto the kill ring creating a new -start of ring position. This function is much like an every- -day lisp push with size considerations. If the length of the -kill ring is greater than the maximum size, then \"older\" -elements will be removed from the ring until the maximum size -is reached.")) + (:documentation "Pushes a vector of objects onto the kill ring +creating a new start of ring position. This function is much +like an everyday Lisp push with size considerations. If the +length of the kill ring is greater than the maximum size, then +\"older\" elements will be removed from the ring until the +maximum size is reached.")) (defgeneric kill-ring-concatenating-push (kr vector) - (:documentation "Concatenates the contents of vector onto the end - of the current contents of the top of the kill ring. - If the kill ring is empty the a new entry is pushed.")) + (:documentation "Concatenates the contents of vector onto the +end of the current contents of the top of the kill ring. If the +kill ring is empty the a new entry is pushed.")) (defgeneric kill-ring-reverse-concatenating-push (kr vector) (:documentation "Concatenates the contents of vector onto the front @@ -91,12 +102,10 @@ (defgeneric kill-ring-yank (kr &optional reset) (:documentation "Returns the vector of objects currently - pointed to by the cursor. If reset is T, a - call to reset-yank-position is called before - the object is yanked. The default for reset - is NIL. If the kill ring is empty, a - condition of type `empty-kill-ring' is - signalled.")) +pointed to by the cursor. If `reset' is T, a call to +`reset-yank-position' is called before the object is yanked. The +default for reset is NIL. If the kill ring is empty, a condition +of type `empty-kill-ring' is signalled.")) (defmethod kill-ring-length ((kr kill-ring)) (nb-elements (kill-ring-chain kr))) @@ -172,4 +181,4 @@ (defparameter *kill-ring* nil "This special variable is bound to the kill ring of the running -application or DREI instance whenever a command is executed.") \ No newline at end of file +application or Drei instance whenever a command is executed.") --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 10:31:37 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/19 11:39:45 1.6 @@ -72,7 +72,7 @@ (defpackage :drei-kill-ring (:use :clim-lisp :flexichain) - (:export #:kill-ring + (:export #:kill-ring #:kill-ring-chain #:kill-ring-cursor #:empty-kill-ring #:kill-ring-length #:kill-ring-max-size #:append-next-p @@ -192,6 +192,15 @@ #:isearch-state #:search-string #:search-mark #:search-forward-p #:search-success-p #:query-replace-state #:string1 #:string2 #:buffers #:mark #:occurrences + + ;; Undo. + #:undo-mixin #:undo-tree #:undo-accumulate #:performing-undo + #:drei-undo-record + #:simple-undo-record + #:insert-record + #:delete-record + #:compound-record + #:with-undo #:drei-buffer #:drei-textual-view #:+drei-textual-view+ --- /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/19 11:39:45 1.2 @@ -34,35 +34,36 @@ one of its child states. Client code is required to supply methods for this function on -client-specific subclasses of undo-record.")) +client-specific subclasses of `undo-record'.")) (defgeneric undo (undo-tree &optional n) - (:documentation "Move the current state n steps up the undo tree and -call flip-undo-record on each step. If the current state is at a -level less than n, a no-more-undo condition is signaled and the -current state is not moved (and no calls to flip-undo-record are -made). + (:documentation "Move the current state `n' steps up the undo +tree and call `flip-undo-record' on each step. If the current +state is at a level less than `n', a `no-more-undo' condition is +signaled and the current state is not moved (and no calls to +`flip-undo-record' are made). As long as no new record are added to the tree, the undo module remembers which branch it was in before a sequence of calls to undo.")) (defgeneric redo (undo-tree &optional n) - (:documentation "Move the current state n steps down the remembered -branch of the undo tree and call flip-undo-record on each step. If -the remembered branch is shorter than n, a no-more-undo condition is -signaled and the current state is not moved (and no calls to -flip-undo-record are made).")) + (:documentation "Move the current state `n' steps down the +remembered branch of the undo tree and call `flip-undo-record' on +each step. If the remembered branch is shorter than `n', a +`no-more-undo' condition is signaled and the current state is not +moved (and no calls to `flip-undo-record' are made).")) (define-condition no-more-undo (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No more undo"))) - (:documentation "This condition is signaled whenever an attempt is made to -call undo on a tree that is in its initial state.")) + (:documentation "A condition of this type is signaled whenever +an attempt is made to call undo when the application is in its +initial state.")) (defclass undo-tree () () - (:documentation "Protocol class for all undo trees")) + (:documentation "The base class for all undo trees.")) (defclass standard-undo-tree (undo-tree) ((current-record :accessor current-record) @@ -70,7 +71,10 @@ (redo-path :initform '() :accessor redo-path) (children :initform '() :accessor children) (depth :initform 0 :reader depth)) - (:documentation "Standard instantiable class for undo trees.")) + (:documentation "The base class for all undo records. + +Client code typically derives subclasses of this class that are +specific to the application.")) (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args) (declare (ignore args)) @@ -78,11 +82,14 @@ (leaf-record tree) tree)) (defclass undo-record () () - (:documentation "The protocol class for all undo records.")) + (:documentation "The base class for all undo records.")) (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) - (tree :initform nil :accessor undo-tree) + (tree :initform nil + :accessor undo-tree + :documentation "The undo tree to which the undo record +belongs.") (children :initform '() :accessor children) (depth :initform nil :accessor depth)) (:documentation "Standard instantiable class for undo records."))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Nov '06

18 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4436/Drei Modified Files: motion.lisp Log Message: Added docstrings. --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/18 22:02:41 1.2 @@ -87,11 +87,16 @@ do (decf (offset mark)))) (defun beep-limit-action (mark original-offset remaining unit syntax) + "This limit action will beep at the user." (declare (ignore mark original-offset remaining unit syntax)) (clim:beep) nil) (defun revert-limit-action (mark original-offset remaining unit syntax) + "This limit action will try to restore the mark state from +before the attempted action. Note that this will not restore any +destructive actions that have been performed, it will only +restore the position of `mark'." (declare (ignore remaining unit syntax)) (setf (offset mark) original-offset) nil) @@ -103,12 +108,14 @@ (remaining :initarg :remaining) (syntax :initarg :syntax)) (:documentation - "Type of conditions signalled by motion functions unable to move.") + "This error condition signifies that a motion cannot be performed.") (:report (lambda (condition stream) (format stream "Motion by ~A reached limit." (slot-value condition 'UNIT))))) (defun error-limit-action (mark original-offset remaining unit syntax) + "This limit action will signal an error of type +`motion-limit-error'." (error 'MOTION-LIMIT-ERROR :mark mark :original-offset original-offset @@ -180,6 +187,9 @@ (t t)))))))) (defun make-diligent-motor (motor fiddler) + "Create and return a diligent motor with a default limit action +of `beep-limit-action'. `Motor' and `fiddler' will take turns +being called until either `motor' succeeds or `fiddler' fails." (labels ((make-limit-action (loser) (labels ((limit-action (mark original-offset remaining unit syntax)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Nov '06

18 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25854/Drei Modified Files: syntax.lisp Log Message: Updated and added docstrings. --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/11 00:08:30 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/18 21:01:46 1.3 @@ -28,7 +28,8 @@ :initform (error "A command table has not been provided for this syntax") :reader command-table) (%cursor-positions :accessor cursor-positions - :initform nil))) + :initform nil)) + (:documentation "The base class for all syntaxes.")) (defun syntaxp (object) "Return T if `object' is an instance of a syntax, NIL @@ -51,9 +52,15 @@ (:documentation "This condition is signaled whenever an attempt is made to execute a by-experssion motion command and no expression is available." )) -(defgeneric update-syntax (buffer syntax)) - -(defgeneric update-syntax-for-display (buffer syntax from to)) +(defgeneric update-syntax (buffer syntax) + (:documentation "Inform the syntax module that it must update +its view of the buffer The low-mark and the high-mark of the +buffer indicate what region has been updated.")) + +(defgeneric update-syntax-for-display (buffer syntax from to) + (:documentation "Inform the syntax module that it must update +its syntactic analysis to cover the region between the two marks +from and to.")) (defgeneric syntax-line-indentation (mark tab-width syntax) (:documentation "Return the correct indentation for the line containing @@ -355,9 +362,12 @@ (defclass parse-tree () ((start-mark :initform nil :initarg :start-mark :reader start-mark) - (size :initform nil :initarg :size))) + (size :initform nil :initarg :size)) + (:documentation "The base class for all parse trees.")) -(defgeneric start-offset (parse-tree)) +(defgeneric start-offset (parse-tree) + (:documentation "The offset in the buffer of the first +character of a parse tree.")) (defmethod start-offset ((tree parse-tree)) (let ((mark (start-mark tree))) @@ -375,7 +385,9 @@ (setf start-mark (clone-mark offset)) (setf (offset start-mark) (offset offset))))) -(defgeneric end-offset (parse-tree)) +(defgeneric end-offset (parse-tree) + (:documentation "The offset in the buffer of the character +following the last one of a parse tree.")) (defmethod end-offset ((tree parse-tree)) (with-slots (start-mark size) tree @@ -402,19 +414,61 @@ ;;; lexer (defclass lexer () - ((buffer :initarg :buffer :reader buffer))) - -(defgeneric nb-lexemes (lexer)) -(defgeneric lexeme (lexer pos)) -(defgeneric insert-lexeme (lexer pos lexeme)) -(defgeneric delete-invalid-lexemes (lexer from to)) -(defgeneric inter-lexeme-object-p (lexer object)) -(defgeneric skip-inter-lexeme-objects (lexer scan)) -(defgeneric update-lex (lexer start-pos end)) -(defgeneric next-lexeme (lexer scan)) + ((buffer :initarg :buffer + :reader buffer + :documentation "The buffer associated with the +lexer.")) + (:documentation "The base class for all lexers.")) + +(defgeneric nb-lexemes (lexer) + (:documentation "Return the number of lexemes in the lexer.")) + +(defgeneric lexeme (lexer pos) + (:documentation "Given a lexer and a position, return the +lexeme in that position in the lexer.")) + +(defgeneric insert-lexeme (lexer pos lexeme) + (:documentation "Insert a lexeme at the position in the lexer. +All lexemes following POS are moved to one position higher.")) + +(defgeneric delete-invalid-lexemes (lexer from to) + (:documentation "Invalidate all lexemes that could have changed +as a result of modifications to the buffer")) + +(defgeneric inter-lexeme-object-p (lexer object) + (:documentation "This generic function is called by the +incremental lexer to determine whether a buffer object is an +inter-lexeme object, typically whitespace. Client code must +supply a method for this generic function.")) + +(defgeneric skip-inter-lexeme-objects (lexer scan) + (:documentation "This generic function is called by the +incremental lexer to skip inter-lexeme buffer objects. The +default method for this generic function increments the scan mark +until the object after the mark is not an inter-lexeme object, or +until the end of the buffer has been reached.")) + +(defgeneric update-lex (lexer start-pos end) + (:documentation "This function is called by client code as part +of the buffer-update protocol to inform the lexer that it needs +to analyze the contents of the buffer at least up to the `end' +mark of the buffer. `start-pos' is the position in the lexeme +sequence at which new lexemes should be inserted.")) + +(defgeneric next-lexeme (lexer scan) + (:documentation "This generic function is called by the +incremental lexer to get a new lexeme from the buffer. Client +code must supply a method for this function that specializes on +the lexer class. It is guaranteed that scan is not at the end of +the buffer, and that the first object after scan is not an +inter-lexeme object. Thus, a lexeme should always be returned by +this function.")) (defclass incremental-lexer (lexer) - ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes))) + ((lexemes :initform (make-instance 'standard-flexichain) :reader lexemes)) + (:documentation "A subclass of lexer which maintains the buffer +in the form of a sequence of lexemes that is updated +incrementally.")) (defmethod nb-lexemes ((lexer incremental-lexer)) (nb-elements (lexemes lexer))) @@ -517,6 +571,7 @@ (defmacro grammar (&body body) + "Create a grammar object from a set of rules." (let ((rule (gensym "RULE")) (rules (gensym "RULES")) (result (gensym "RESULT")))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Nov '06

18 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24084/Drei Modified Files: input-editor.lisp drei.lisp drei-clim.lisp Log Message: Fixed slight redisplay issue with minibuffer and cleared up a bit of general output code. Also moved the use of `accepting-from-user' macro so that command arguments will be evaluated within its scope. This also means that it is the responsibility of the Drei variant to use it if needed. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/17 20:18:56 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/18 20:59:28 1.5 @@ -375,17 +375,18 @@ ;; We narrow the buffer to the input position, so the user won't ;; be able to erase the original command (when entering command ;; arguments) or stuff like argument prompts. - (drei-core:with-narrowed-buffer (drei (input-position stream) t t) - (handler-case (process-gestures-or-command drei) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture (c) - (if (member (abort-gesture-event c) - *abort-gestures* - :test #'event-matches-gesture-name-p) - (signal 'abort-gesture :event (abort-gesture-event c)) - (when was-directly-processing - (display-message "Aborted")))))) + (accepting-from-user (drei) + (drei-core:with-narrowed-buffer (drei (input-position stream) t t) + (handler-case (process-gestures-or-command drei) + (unbound-gesture-sequence (c) + (display-message "~A is unbound" (gesture-name (gestures c)))) + (abort-gesture (c) + (if (member (abort-gesture-event c) + *abort-gestures* + :test #'event-matches-gesture-name-p) + (signal 'abort-gesture :event (abort-gesture-event c)) + (when was-directly-processing + (display-message "Aborted"))))))) ;; Will also take care of redisplaying minibuffer. (display-drei drei) (let ((first-mismatch (mismatch before (stream-input-buffer stream)))) --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/17 20:18:56 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/18 20:59:28 1.7 @@ -806,6 +806,5 @@ :update-syntax t :with-undo t) (handling-drei-conditions - (accepting-from-user (drei) - (apply (command-name command) (command-arguments command))) + (apply (command-name command) (command-arguments command)) (setf (previous-command drei) command)))))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/17 20:18:56 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/18 20:59:28 1.8 @@ -257,22 +257,18 @@ ;; It is important that the minibuffer of the Drei object is ;; actually the minibuffer that will be used for output, or it ;; will not be properly redisplayed by `display-drei'. - (letf (((minibuffer drei) (or (minibuffer drei) *minibuffer*))) - (handler-case (process-gesture drei gesture) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture () - (display-message "Aborted")))))) - -(defmethod execute-drei-command :around ((drei drei-gadget-pane) command) - (with-accessors ((buffer buffer)) drei - (let* ((*minibuffer* (or *minibuffer* - (unless (eq drei *standard-input*) - *standard-input*)))) - (call-next-method)) - (redisplay-frame-pane (pane-frame drei) drei) - (when (modified-p buffer) - (clear-modify buffer)))) + (accepting-from-user (drei) + (letf (((minibuffer drei) (or (minibuffer drei) *minibuffer* + (unless (eq drei *standard-input*) + *standard-input*)))) + (handler-case (process-gesture drei gesture) + (unbound-gesture-sequence (c) + (display-message "~A is unbound" (gesture-name (gestures c)))) + (abort-gesture () + (display-message "Aborted"))) + (display-drei drei) + (when (modified-p (buffer drei)) + (clear-modify (buffer drei))))))) (defmethod execute-drei-command :after ((drei drei-gadget-pane) command) (with-accessors ((buffer buffer)) drei @@ -359,9 +355,10 @@ a minibuffer.")) (defmethod display-drei :after ((drei drei)) - (with-accessors ((minibuffer minibuffer)) drei - (when (and minibuffer (not (eq minibuffer (editor-pane drei)))) - (redisplay-frame-pane (pane-frame minibuffer) minibuffer)))) + (when (and *minibuffer* (not (eq *minibuffer* (editor-pane drei)))) + ;; We need to use :force-p t to remove any existing output from + ;; the pane. + (redisplay-frame-pane (pane-frame *minibuffer*) *minibuffer* :force-p t))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Nov '06

18 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23318/Drei Modified Files: misc-commands.lisp Log Message: These commands were broken, now they work. --- /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/18 20:52:52 1.2 @@ -50,26 +50,20 @@ (define-command (com-count-lines-page :name t :command-table info-table) () "Print the number of lines in the current page. Also prints the number of lines before and after point (as '(b + a)')." - (let* ((pane (current-window)) - (syntax (syntax (buffer pane))) - (point (point pane)) - (start (clone-mark point)) - (end (clone-mark point))) - (backward-page start syntax) - (forward-page end syntax) + (let* ((start (clone-mark *current-point*)) + (end (clone-mark *current-point*))) + (backward-page start *current-syntax* 1 nil) + (forward-page end *current-syntax* 1 nil) (let ((total (number-of-lines-in-region start end)) - (before (number-of-lines-in-region start point)) - (after (number-of-lines-in-region point end))) + (before (number-of-lines-in-region start *current-point*)) + (after (number-of-lines-in-region *current-point* end))) (display-message "Page has ~A lines (~A + ~A)" (1+ total) before after)))) (define-command (com-count-lines-region :name t :command-table info-table) () "Print the number of lines in the region. Also prints the number of objects (as 'o character[s]')." - (let* ((pane (current-window)) - (point (point pane)) - (mark (mark pane)) - (lines (number-of-lines-in-region point mark)) - (chars (abs (- (offset point) (offset mark))))) + (let* ((lines (number-of-lines-in-region *current-point* *current-mark*)) + (chars (abs (- (offset *current-point*) (offset *current-mark*))))) (display-message "Region has ~D line~:P, ~D character~:P." (1+ lines) chars))) (set-key `(com-eval-expression ,*unsupplied-argument-marker* ,*numeric-argument-p*) @@ -82,4 +76,4 @@ (set-key 'com-count-lines-region 'info-table - '((#\= :meta))) \ No newline at end of file + '((#\= :meta)))

1 0