mcclim-cvs November 2006

mcclim-cvs@common-lisp.net

6 participants
128 discussions

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

21 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15276/Drei Modified Files: lisp-syntax.lisp Log Message: The Drei accept method for expressions seriously stresses the Lisp syntax, and requires very consistent representation of incomplete/complete tokens. This patch is a start, but there are still tokens that need to be handled (and since the code is very repetitive, a generator macro should probably also be written). I don't really have the theoretical knowledge to work very much with parsers, so my solutions might not be as elegant as possible. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/11 00:08:30 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/21 23:28:07 1.5 @@ -1006,7 +1006,7 @@ (define-parser-state |' form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow quote-lexeme) |' |) -(define-new-lisp-state (|' | form) |' form |) +(define-new-lisp-state (|' | complete-form-mixin) |' form |) (define-new-lisp-state (|' | comment) |' |) (define-new-lisp-state (|' | unmatched-right-parenthesis-lexeme) |( form* ) |) @@ -1032,7 +1032,7 @@ (define-parser-state |` form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow backquote-lexeme) |` |) -(define-new-lisp-state (|` | form) |` form |) +(define-new-lisp-state (|` | complete-form-mixin) |` form |) (define-new-lisp-state (|` | comment) |` |) (define-new-lisp-state (|` | unmatched-right-parenthesis-lexeme) |( form* ) |) @@ -1083,17 +1083,23 @@ ;;; parse trees (defclass function-form (form) ()) +(defclass complete-function-form (form complete-form-mixin) ()) +(defclass incomplete-function-form (form incomplete-form-mixin) ()) (define-parser-state |#' | (form-may-follow) ()) (define-parser-state |#' form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow function-lexeme) |#' |) -(define-new-lisp-state (|#' | form) |#' form |) +(define-new-lisp-state (|#' | complete-form-mixin) |#' form |) (define-new-lisp-state (|#' | comment) |#' |) ;;; reduce according to the rule form -> #' form (define-lisp-action (|#' form | t) - (reduce-until-type function-form function-lexeme)) + (reduce-until-type complete-function-form function-lexeme)) +(define-lisp-action (|#' | unmatched-right-parenthesis-lexeme) + (reduce-until-type incomplete-function-form function-lexeme)) +(define-lisp-action (|#' | (eql nil)) + (reduce-until-type incomplete-function-form function-lexeme)) ;;;;;;;;;;;;;;;; Reader conditionals @@ -1219,17 +1225,21 @@ ;;; parse trees (defclass pathname-form (form) ()) +(defclass complete-pathname-form (pathname-form complete-form-mixin) ()) +(defclass incomplete-pathname-form (pathname-form incomplete-form-mixin) ()) (define-parser-state |#P | (form-may-follow) ()) (define-parser-state |#P form | (lexer-toplevel-state parser-state) ()) (define-new-lisp-state (form-may-follow pathname-start-lexeme) |#P |) -(define-new-lisp-state (|#P | form) |#P form |) +(define-new-lisp-state (|#P | complete-form-mixin) |#P form |) (define-new-lisp-state (|#P | comment) |#P |) ;;; reduce according to the rule form -> #P form (define-lisp-action (|#P form | t) - (reduce-until-type pathname-form pathname-start-lexeme)) + (reduce-until-type complete-pathname-form pathname-start-lexeme)) +(define-lisp-action (|#P | (eql nil)) + (reduce-until-type incomplete-pathname-form pathname-start-lexeme)) ;;;;;;;;;;;;;;;; undefined reader macro @@ -2606,6 +2616,26 @@ (defmethod token-to-object ((syntax lisp-syntax) (token literal-object-lexeme) &key &allow-other-keys) (object-after (start-mark token))) +(defmethod token-to-object ((syntax lisp-syntax) (token pathname-form) &key &allow-other-keys) + (read-from-string (token-string syntax token))) + +(defmethod token-to-object ((syntax lisp-syntax) (token incomplete-pathname-form) &rest args &key read &allow-other-keys) + (if read + ;; Will cause a reader error (which is what we want). + (call-next-method) + ;; Try to create a pathname as much as possible. + (let ((pathspec-token (second (children token)))) + (pathname (if pathspec-token + (apply #'token-to-object syntax pathspec-token + ;; Since `pathspec-token' will be + ;; incomplete, `read'ing from it is + ;; probably bad. + :read nil args) + ""))))) + +(defmethod token-to-object ((syntax lisp-syntax) (token complete-function-form) &rest args &key &allow-other-keys) + (fdefinition (apply #'token-to-object syntax (second (children token)) args))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Arglist fetching. @@ -2693,6 +2723,9 @@ (defmethod indent-form ((syntax lisp-syntax) (tree long-comment-form) path) (values tree 0)) +(defmethod indent-form ((syntax lisp-syntax) (tree pathname-form) path) + (values tree 0)) + (defmethod indent-form ((syntax lisp-syntax) (tree quote-form) path) (indent-list syntax (elt-noncomment (children tree) (car path)) (cdr path)))

1 0

[mcclim-cvs] CVS mcclim/Goatee
by ahefner 21 Nov '06

21 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv8924 Modified Files: goatee-command.lisp Log Message: Change #\Delete to #\Rubout, fixing problem with clisp/win32, and resolving OpenMCL confusion. --- /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/03/14 12:27:24 1.22 +++ /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/11/21 22:59:12 1.23 @@ -285,10 +285,7 @@ 'delete-character *simple-area-gesture-table*) -;;; XXX In OpenMCL Darwin, #\Delete and #\Backspace map to the same -;;; character (bs)! This is not the place for silly conditionals; do -;;; we have to punt on CL characters, hack our own read table, or what? -(add-gesture-command-to-table '(#-openmcl #\Delete #+openmcl #\DEL) +(add-gesture-command-to-table '(#\Rubout) 'delete-character *simple-area-gesture-table*)

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 21 Nov '06

21 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv5025 Modified Files: listener.lisp Log Message: Improved ideological purity. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/19 15:31:43 1.29 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/21 22:39:32 1.30 @@ -110,46 +110,7 @@ (defun display-wholine (frame pane) (invoke-and-center-output pane (lambda () (generate-wholine-contents frame pane)) - :horizontally nil :hpad 5)) - -;; This is a toy command history. -;; Possibly this should become something integrated with the presentation -;; histories, which I have not played with. - -(defclass command-history-mixin () - ((history :initform nil :accessor history) - (history-length :initform 25 :initarg :history-length :accessor history-length))) - -(defmethod execute-frame-command :after ((frame command-history-mixin) command) - ;; FIXME: not safe against commands sent from other frames. - (push command (history frame)) - (when (> (length (history frame)) (history-length frame)) - (setf (history frame) - (subseq (history frame) 0 (max (length (history frame)) - (history-length frame)))))) - -(define-command (com-show-command-history :name "Show Command History" - :command-table application-commands - :menu ("Show Command History" :after "Clear Output History")) - () - (formatting-table () - (loop for n from 0 by 1 - for command in (history *application-frame*) - do (formatting-row () - (formatting-cell () - (princ n)) - (formatting-cell () - (present command 'command)))))) - -(defparameter *listener-initial-function* nil) - -(defun listener-initial-display-function (frame pane) - (declare (ignore frame pane)) - (when *listener-initial-function* - (funcall-in-listener - (lambda () - (funcall *listener-initial-function*) - (fresh-line))))) + :horizontally nil :hpad 5)) ;;; Listener view ;;; @@ -175,6 +136,7 @@ (define-presentation-method accept :around ((type sequence) stream (view listener-view) &key default default-type) + (declare (ignorable default default-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 @@ -201,7 +163,7 @@ (defmethod stream-present :around ((stream listener-interactor-pane) object type &rest args &key (single-box nil sbp) &allow-other-keys) - (apply #'call-next-method stream object type :single-box t args) + (apply #'call-next-method stream object type :single-box t args) ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all ;; the keyword arguments explicitly. *sigh*. #+nil @@ -210,16 +172,14 @@ (apply #'call-next-method stream object type :single-box t args))) ;;; Listener application frame -(define-application-frame listener (standard-application-frame - command-history-mixin) +(define-application-frame listener (standard-application-frame) ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) (:panes (interactor-container (make-clim-stream-pane :type 'listener-interactor-pane - :name 'interactor :scroll-bars t :display-time t - :display-function #'listener-initial-display-function)) + :name 'interactor :scroll-bars t)) (doc :pointer-documentation) (wholine (make-pane 'wholine-pane :display-function 'display-wholine :scroll-bars nil @@ -241,148 +201,14 @@ ;;; Lisp listener command loop -;; Set this to true if you want the listener to bind *debug-io* to the -;; listener window. -(defparameter *listener-use-debug-io* #+hefner t #-hefner nil) - -(defmethod run-frame-top-level ((frame listener) &key listener-funcall &allow-other-keys) - (let ((*debug-io* (if *listener-use-debug-io* - (get-frame-pane frame 'interactor) - *debug-io*)) - ;; Borrowed from OpenMCL. - ;; from CLtL2, table 22-7: - (*listener-initial-function* listener-funcall) - (*package* *package*) - (*print-array* *print-array*) - (*print-base* *print-base*) - (*print-case* *print-case*) - (*print-circle* *print-circle*) - (*print-escape* *print-escape*) - (*print-gensym* *print-gensym*) - (*print-length* *print-length*) - (*print-level* *print-level*) - (*print-lines* *print-lines*) - (*print-miser-width* *print-miser-width*) - (*print-pprint-dispatch* *print-pprint-dispatch*) - (*print-pretty* *print-pretty*) - (*print-radix* *print-radix*) - (*print-readably* *print-readably*) - (*print-right-margin* *print-right-margin*) - (*read-base* *read-base*) - (*read-default-float-format* *read-default-float-format*) - (*read-eval* *read-eval*) - (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) - (setf (stream-default-view (get-frame-pane frame 'interactor)) - +listener-view+) - (setf (stream-default-view (get-frame-pane frame 'doc)) - +listener-pointer-documentation-view+) - (loop while - (catch 'return-to-listener - (restart-case (call-next-method) - (return-to-listener () - :report "Return to listener." - (throw 'return-to-listener t))))))) - -;; Oops. As we've ditched our custom toplevel, we now have to duplicate all -;; this setup work to implement one little trick. -(defun funcall-in-listener (fn) - (let* ((frame *application-frame*) - (*standard-input* (or (frame-standard-input frame) - *standard-input*)) - (*standard-output* (or (frame-standard-output frame) - *standard-output*)) - (query-io (frame-query-io frame)) - (*query-io* (or query-io *query-io*)) - (*pointer-documentation-output* (frame-pointer-documentation-output frame)) - (interactorp (typep *query-io* 'interactor-pane))) - ;; FIXME - Something strange is happening which causes the initial command - ;; prompt to be indented incorrectly after performing this output. Various - ;; things like as calling TERPRI, manually moving the cursor, and closing - ;; the open output record, don't seem to help. - (with-room-for-graphics (*standard-output* :first-quadrant nil - :move-cursor t) - (funcall fn) - (stream-close-text-output-record *standard-output*) - (fresh-line)))) - -(defparameter *form-opening-characters* - '(#\( #\) #\[ #\] #\# #\; #\: #\' #\" #\* #\, #\` #\- - #\+ #\/ #\0 #\1 #\2 #\3 #\4 #\5 #\6 #\7 #\8 #\9)) - (defmethod read-frame-command ((frame listener) &key (stream *standard-input*)) "Specialized for the listener, read a lisp form to eval, or a command." - (if (system-command-reader frame) - (multiple-value-bind (object type) - (accept 'command-or-form :stream stream :prompt nil) - (if (presentation-subtypep type 'command) - object - `(com-eval ,object))) - (let* ((command-table (find-command-table 'listener)) - (*accelerator-gestures* (climi::compute-inherited-keystrokes command-table)) - object type) - (flet ((sensitizer (stream cont) - (case type - ((command) (with-output-as-presentation (stream object type :single-box t) - (funcall cont))) - ((form) - (with-output-as-presentation (stream object 'command :single-box t) - (with-output-as-presentation - (stream (cadr object) 'expression :single-box t) - (with-output-as-presentation - (stream (cadr object) - (presentation-type-of (cadr object)) - :single-box t) - (funcall cont))))) - (t (funcall cont))))) - (handler-case - ;; Body - (with-input-editing - (stream :input-sensitizer #'sensitizer) - (let ((c (read-gesture :stream stream :peek-p t))) - (setf object - (if (member c *form-opening-characters*) - (prog2 - (when (char= c #\,) - ;; lispm behavior - (read-gesture :stream stream)) - (list 'com-eval (accept 'form :stream stream :prompt nil)) - (setf type 'form)) - (prog1 - (accept '(command :command-table listener) :stream stream - :prompt nil) - (setf type 'command)))))) - ;; Handlers - ((or simple-parse-error input-not-of-required-type) (c) - (beep) - (fresh-line *query-io*) - (princ c *query-io*) - (terpri *query-io*) - nil) - (accelerator-gesture (c) - (let ((command (lookup-keystroke-command-item (accelerator-gesture-event c) - command-table))) - (setf ;type 'command - object (if (partial-command-p command) - (funcall *partial-command-parser* - command-table stream command - (position *unsupplied-argument-marker* command)) - command)))))) - object))) - -(defmethod read-frame-command :around ((frame listener) - &key (stream *standard-input*)) - "Read a command or form, taking care to manage the input context - and whatever else need be done." - (multiple-value-bind (x y) (stream-cursor-position stream) - (with-input-context ('command) (object object-type) - (call-next-method) - (command - ;; Kludge the cursor position - Goatee will have moved it all around - (setf (stream-cursor-position stream) (values x y)) - (present object object-type :stream stream - :view (stream-default-view stream)) - object)))) + (multiple-value-bind (object type) + (accept 'command-or-form :stream stream :prompt nil) + (format *trace-output* "~&object=~W~%" object) + (if (presentation-subtypep type 'command) + object + `(com-eval ,object)))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) @@ -394,21 +220,15 @@ (defmethod frame-standard-output ((frame listener)) (get-frame-pane frame 'interactor)) -(defun run-listener (&key (system-command-reader nil) - (new-process nil) +(defun run-listener (&key (new-process nil) (width 760) (height 550) - (process-name "Listener") - (eval nil)) + (process-name "Listener")) (flet ((run () (let ((frame (make-application-frame 'listener - :width width :height height - :system-command-reader system-command-reader))) - (run-frame-top-level - frame :listener-funcall (cond ((null eval) nil) - ((functionp eval) eval) - (t (lambda () (eval eval)))))))) + :width width :height height))) + (run-frame-top-level frame)))) (if new-process (clim-sys:make-process #'run :name process-name) (run))))

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by ahefner 21 Nov '06

21 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv9740 Modified Files: dev-commands.lisp Log Message: Bind '-' during evaluation. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 12:30:56 1.37 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/21 20:34:40 1.38 @@ -1477,7 +1477,8 @@ (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) - (let ((values (multiple-value-list (eval form)))) + (let* ((- form) + (values (multiple-value-list (eval form)))) (fresh-line) (shuffle-specials form values) (display-evalues values)

1 0

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

20 Nov '06

Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv25370 Modified Files: ffi.lisp gtk-ffi.lisp Log Message: Move XGetErrorText back into gtk-ffi.lisp; disable it on windows. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 18:08:16 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/20 19:53:44 1.5 @@ -1340,11 +1340,3 @@ (window :pointer) ;GtkWindow * (title :string) ;const gchar * ) - -(defcfun "XGetErrorText" - :int - (dpy :pointer) ;Display * - (code :int) ;int - (buffer :string) ;char * - (nbytes :int) ;int - ) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/19 15:55:10 1.15 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/20 19:53:44 1.16 @@ -316,6 +316,15 @@ (index :int) &rest) +#-(or win32 windows mswindows) +(defcfun "XGetErrorText" + :int + (dpy :pointer) ;Display * + (code :int) ;int + (buffer :string) ;char * + (nbytes :int) ;int + ) + (defconstant GDK_CURRENT_TIME 0) ;; fixme: GtkWidgetFlags is an enum, why is it not in the object file?

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 20 Nov '06

20 Nov '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25665 Modified Files: presentation-defs.lisp input-editing-drei.lisp Log Message: Added support for navigating presentation histories in Drei. Use M-p and M-n to browse previous input for a specific presentation type. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/08 01:18:22 1.58 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/20 09:00:56 1.59 @@ -480,9 +480,12 @@ (define-presentation-method presentation-type-history-for-stream ((type t) (stream input-editing-stream)) - (if (not (stream-rescanning-p stream)) - (funcall-presentation-generic-function presentation-type-history type) - nil)) + ;; What is the purpose of this? Makes stuff harder to do, so + ;; commented out... + ;;(if (not (stream-rescanning-p stream)) + ;; (funcall-presentation-generic-function presentation-type-history type) + ;; nil) + (funcall-presentation-generic-function presentation-type-history type)) (defun presentation-history-insert (history object ptype) (goatee::ring-obj-insert (cons object ptype) history)) @@ -508,6 +511,18 @@ end finally (return (values nil nil))))) +(defun presentation-history-previous (history ptype) + (let ((first-object (goatee::backward history))) + (loop + for first-time = t then nil + for cell = first-object then (goatee::backward history) + for (object . object-ptype) = (goatee::contents cell) + while (or first-time (not (eq first-object cell))) + if (presentation-subtypep object-ptype ptype) + return (values object object-ptype) + end + finally (return (values nil nil))))) + (defmacro with-object-on-history ((history object ptype) &body body) `(goatee::with-object-on-ring ((cons ,object ,ptype) ,history) ,@body)) --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/11/08 01:18:22 1.1 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/11/20 09:00:56 1.2 @@ -190,3 +190,46 @@ (defmethod input-editing-stream-bounding-rectangle ((stream standard-input-editing-stream)) (bounding-rectangle* (drei:drei-instance stream))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; +;;; Presentation type history support +;;; +;;; Presentation histories are pretty underspecified, so we have to +;;; rely on internal features and implement input-editor support in +;;; CLIM-INTERNALS (Goatee does the same trick). + +(defun history-yank (stream input-buffer gesture numeric-argument) + (let* ((accepting-type *active-history-type*) + (history (and accepting-type + (presentation-type-history accepting-type)))) + (when history + (multiple-value-bind (object type) + (presentation-history-head history accepting-type) + (presentation-replace-input stream object type (stream-default-view stream)))))) + +(defun history-yank-next (stream input-buffer gesture numeric-argument) + (let* ((accepting-type *active-history-type*) + (history (and accepting-type + (presentation-type-history accepting-type)))) + (when history + (multiple-value-bind (object type) + (presentation-history-next history accepting-type) + (when type + (presentation-replace-input stream object type (stream-default-view stream))))))) + +(defun history-yank-previous (stream input-buffer gesture numeric-argument) + (let* ((accepting-type *active-history-type*) + (history (and accepting-type + (presentation-type-history accepting-type)))) + (when history + (multiple-value-bind (object type) + (presentation-history-previous history accepting-type) + (when type + (presentation-replace-input stream object type (stream-default-view stream))))))) + +(add-input-editor-command '((#\y :control :meta)) 'history-yank) + +(add-input-editor-command '((#\p :meta)) 'history-yank-next) + +(add-input-editor-command '((#\n :meta)) 'history-yank-previous)

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-serv22486 Modified Files: NEWS Log Message: Native option panes. * ffi.lisp (gtk_combo_box_append_text, gtk_combo_box_get_active, gtk_combo_box_new_text, gtk_combo_box_set_active): New. * frame-manager.lisp (MAKE-PANE-2 GENERIC-OPTION-PANE): New. * gadgets.lisp (GTK-OPTION-PANE, REALIZE-NATIVE-WIDGET, OPTION-PANE-SET-ACTIVE, (SETF GADGET-VALUE, CONNECT-NATIVE-SIGNALS, HANDLE-EVENT)): New. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/19 17:32:10 1.7 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/19 18:09:07 1.8 @@ -3,7 +3,8 @@ ** backend improvements: Gtkairo *** Double buffering is now supported (fixes disappearing widgets on Windows). *** X errors no longer terminate the lisp process. -*** Native implementation of context menus, list panes, and label panes. +*** Native implementation of context menus, list panes, label panes, and + option panes. ** Improvement: Added new editor substrate ("Drei"). * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2:

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-serv22356 Modified Files: ffi.lisp frame-manager.lisp gadgets.lisp Log Message: Native option panes. * ffi.lisp (gtk_combo_box_append_text, gtk_combo_box_get_active, gtk_combo_box_new_text, gtk_combo_box_set_active): New. * frame-manager.lisp (MAKE-PANE-2 GENERIC-OPTION-PANE): New. * gadgets.lisp (GTK-OPTION-PANE, REALIZE-NATIVE-WIDGET, OPTION-PANE-SET-ACTIVE, (SETF GADGET-VALUE, CONNECT-NATIVE-SIGNALS, HANDLE-EVENT)): New. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 17:31:20 1.3 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/19 18:08:16 1.4 @@ -934,6 +934,25 @@ (label :string) ;const gchar * ) +(defcfun "gtk_combo_box_append_text" + :void + (combo_box :pointer) ;GtkComboBox * + (text :string) ;const gchar * + ) + +(defcfun "gtk_combo_box_get_active" + :int + (combo_box :pointer) ;GtkComboBox * + ) + +(defcfun "gtk_combo_box_new_text" :pointer) + +(defcfun "gtk_combo_box_set_active" + :void + (combo_box :pointer) ;GtkComboBox * + (index_ :int) ;gint + ) + (defcfun "gtk_container_add" :void (container :pointer) ;GtkContainer * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/19 17:31:20 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/19 18:08:16 1.9 @@ -99,6 +99,9 @@ (defmethod make-pane-2 ((type (eql 'clim:label-pane)) &rest initargs) (apply #'make-instance 'gtk-label-pane initargs)) +(defmethod make-pane-2 ((type (eql 'clim:generic-option-pane)) &rest initargs) + (apply #'make-instance 'gtk-option-pane initargs)) + (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame application-frame)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 17:31:20 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 18:08:16 1.12 @@ -51,6 +51,10 @@ ((title :initarg :title :initform "" :accessor list-pane-title) (tree-view :accessor list-pane-tree-view))) +(defclass gtk-option-pane + (native-widget-mixin option-pane climi::meta-list-pane) + ()) + (defclass native-slider (native-widget-mixin climi::slider-gadget) ((climi::show-value-p :type boolean :initform nil @@ -174,6 +178,15 @@ (cffi:null-pointer)) result)))) +(defmethod realize-native-widget ((sheet gtk-option-pane)) + (let* ((widget (gtk_combo_box_new_text)) + (name-key (climi::list-pane-name-key sheet))) + (dolist (i (climi::list-pane-items sheet)) + (cffi:with-foreign-string (n (funcall name-key i)) + (gtk_combo_box_append_text widget n))) + (option-pane-set-active sheet widget) + widget)) + (defun gtk-list-select-value (sheet value) (let ((path (gtk_tree_path_new_from_indices @@ -201,6 +214,22 @@ (when mirror (gtk-list-reset-selection gadget))))) +(defun option-pane-set-active (sheet widget) + (gtk_combo_box_set_active + widget + (position (gadget-value sheet) + (climi::list-pane-items sheet) + :key (climi::list-pane-value-key sheet) + :test (climi::list-pane-test sheet)))) + +(defmethod (setf gadget-value) :after + (value (gadget gtk-option-pane) &key invoke-callback) + (declare (ignore invoke-callback)) + (with-gtk () + (let ((mirror (sheet-direct-mirror gadget))) + (when mirror + (option-pane-set-active gadget (mirror-widget mirror)))))) + (defun make-scale (fn sheet) (let* ((min (df (gadget-min-value sheet))) (max (df (gadget-max-value sheet))) @@ -364,6 +393,9 @@ ;; no signals ) +(defmethod connect-native-signals ((sheet gtk-option-pane) widget) + (connect-signal widget "changed" 'magic-clicked-handler)) + ;;;; Event handling @@ -451,6 +483,13 @@ when (gethash i *list-selection-result*) collect (funcall value-key value))))))) +(defmethod handle-event ((pane gtk-option-pane) (event magic-gadget-event)) + (setf (gadget-value pane :invoke-callback t) + (funcall (climi::list-pane-value-key pane) + (elt (climi::list-pane-items pane) + (gtk_combo_box_get_active + (mirror-widget (sheet-direct-mirror pane))))))) + ;;; COMPOSE-SPACE

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-serv15667 Modified Files: NEWS 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/NEWS 2006/11/12 20:12:19 1.6 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/19 17:32:10 1.7 @@ -3,7 +3,7 @@ ** backend improvements: Gtkairo *** Double buffering is now supported (fixes disappearing widgets on Windows). *** X errors no longer terminate the lisp process. -*** Native implementation of context menus and list panes. +*** Native implementation of context menus, list panes, and label panes. ** Improvement: Added new editor substrate ("Drei"). * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2:

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-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

← Newer
1
2
3
4
5
6
7
...
13
Older →

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs November 2006