From thenriksen at common-lisp.net Wed Nov 1 13:02:30 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 1 Nov 2006 08:02:30 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061101130230.0F8F51C09F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv12052 Modified Files: mcclim.asd Log Message: Added the views.lisp example to the CLIM-EXAMPLES system definition. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/10/29 08:31:06 1.26 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/01 13:02:29 1.27 @@ -348,7 +348,8 @@ (:file "draggable-graph") (:file "text-size-test") (:file "drawing-benchmark") - (:file "logic-cube"))) + (:file "logic-cube") + (:file "views"))) (:module "Goatee" :components ((:file "goatee-test"))))) From afuchs at common-lisp.net Thu Nov 2 17:28:42 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 12:28:42 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102172842.AB4B84E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15340 Added Files: NEWS Log Message: Add NEWS file. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/02 17:28:42 NONE +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/02 17:28:42 1.1 * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the server search path ** improvement: with-output-as-gadget now sets the correct cursor position when incremental redisplay is active. ** specification compliance: INVOKE-WITH-NEW-OUTPUT-RECORD's argument list now is the same as the one in the Franz CLIM user guide. ** improvement: The text field cursor is now a solid block again. ** backend improvement: the PostScript backend now outputs correct EPS ** improvement: Graph nodes can now be dragged ** improvement: Possibilities when reading from COMPLETE-FROM-GENERATOR are now sorted alphabetically. ** new experimental backend: gtkairo (loads on SBCL, CMUCL and SCL): Uses GTK+ for gadgets and cairo for rendering graphics. ** Bug fix: incremental-redisplay does no longer leak memory ** improvement: incremental-redisplay is now a little faster ** Bug fix: Invisible text cursors no longer leave a dangling space behind the text output record ** improvement: commands whose names are shadowed in child command tables are now suggested in preference to their parents. ** Bug fix: (setf stream-cursor-position) and output record replay on encapsulating streams work now. ** Bug fix: Invoking command menu items in frames with no interactor works now. ** Bug fix: DESTROY-PORT removes the port even if an error occurs while closing the port ** Bug fix: make-process now sets the process name on SBCL ** specification compliance: MENU-CHOOSE now supports almost all features demanded in the CLIM 2.0 specification. ** improvement: new and improved ACCEPT presentation method for expressions on interactive streams. ** specification compliance: LOOKUP-KEYSTROKE-ITEM no longer accepts the :errorp argument. ** Bug fix: incremental redisplay no longer breaks on output records that had no children. ** Bug fix: arrow head sizes are now transformed along with the line thickness. ** improvement: resizing a viewport's child will now move the viewport's focus. ** improvement: loading mcclim.asd no longer shows a code deletion note on SBCL. ** new demo: logic-cube ** compatibility: Add support for post-1.0 openmcl, and for Allegro Common Lisp 8.0 (ansi mode). ** new example application showing use of CLIM views. From afuchs at common-lisp.net Thu Nov 2 17:48:50 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 12:48:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102174850.7E22452001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv18332 Modified Files: mcclim.asd Log Message: Add release notes and set the version on the MCCLIM system --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/01 13:02:29 1.27 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 17:48:50 1.28 @@ -319,6 +319,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim + :version "0.9.3" :depends-on (:clim-looks)) ;;; CLIM-Examples depends on having at least one backend loaded. From afuchs at common-lisp.net Thu Nov 2 17:48:50 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 12:48:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20061102174850.AD13653000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv18332/ReleaseNotes Added Files: 0-9-3-all-souls'-day Log Message: Add release notes and set the version on the MCCLIM system --- /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-3-all-souls'-day 2006/11/02 17:48:50 NONE +++ /project/mcclim/cvsroot/mcclim/ReleaseNotes/0-9-3-all-souls'-day 2006/11/02 17:48:50 1.1 From afuchs at common-lisp.net Thu Nov 2 18:06:41 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:06:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20061102180641.302EA56001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv21360/Webpage Modified Files: index.html Log Message: Update Web Page for 0.9.3 --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/10/30 22:20:33 1.14 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:06:41 1.15 @@ -54,12 +54,16 @@

Releases

- The most recent release of McCLIM is 0.9.2, in March 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL. + The most recent release of McCLIM is 0.9.3, in November 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

A snapshot of the CVS repository is made nightly.

Recent News

+ 2006-11-02: McCLIM 0.9.3 "All Saints' Day" released. +

+ +

2006-03-30: Highly-experimental binaries of McCLIM 0.9.2, set up to start up the McCLIM listener, and incorporating the McCLIM demos as well as a graphical debugger and inspector, @@ -116,7 +120,7 @@


-$Date: 2006/10/30 22:20:33 $ +$Date: 2006/11/02 18:06:41 $ From afuchs at common-lisp.net Thu Nov 2 18:06:41 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:06:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20061102180641.6088858000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv21360/Webpage/downloads Modified Files: index.html Log Message: Update Web Page for 0.9.3 --- /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/03/26 20:19:53 1.13 +++ /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/11/02 18:06:41 1.14 @@ -42,17 +42,17 @@ >mcclim-cvs : CVS commit messages

Tarballs

+

Releases

+

The most recent release of McCLIM is 0.9.3, in Nobember 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

- A compressed tar file of the sources is made nightly. + A compressed tar file of the repository is made nightly.

-

Releases

- The most recent release of McCLIM is 0.9.2, in March 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

-$Date: 2006/03/26 20:19:53 $ +$Date: 2006/11/02 18:06:41 $ From afuchs at common-lisp.net Thu Nov 2 18:08:29 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:08:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage/downloads Message-ID: <20061102180829.AD3235F001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage/downloads In directory clnet:/tmp/cvs-serv21558/downloads Modified Files: index.html Log Message: Agh. forgot an instance of .2 --- /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/11/02 18:06:41 1.14 +++ /project/mcclim/cvsroot/mcclim/Webpage/downloads/index.html 2006/11/02 18:08:29 1.15 @@ -43,7 +43,7 @@

Tarballs

Releases

-

The most recent release of McCLIM is 0.9.3, in Nobember 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL.

+

The most recent release of McCLIM is 0.9.3, in Nobember 2006, available here: mcclim-0.9.3.tar.gz. It is also available via ASDF-INSTALL.

A compressed tar file of the repository is made nightly.

@@ -52,7 +52,7 @@

-$Date: 2006/11/02 18:06:41 $ +$Date: 2006/11/02 18:08:29 $ From afuchs at common-lisp.net Thu Nov 2 18:08:29 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:08:29 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20061102180829.7A8E75F000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv21558 Modified Files: index.html Log Message: Agh. forgot an instance of .2 --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:06:41 1.15 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:08:26 1.16 @@ -54,7 +54,7 @@

Releases

- The most recent release of McCLIM is 0.9.3, in November 2006, available here: mcclim-0.9.2.tar.gz. It is also available via ASDF-INSTALL. + The most recent release of McCLIM is 0.9.3, in November 2006, available here: mcclim-0.9.3.tar.gz. It is also available via ASDF-INSTALL.

A snapshot of the CVS repository is made nightly.

@@ -120,7 +120,7 @@

-$Date: 2006/11/02 18:06:41 $ +$Date: 2006/11/02 18:08:26 $ From afuchs at common-lisp.net Thu Nov 2 18:16:22 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:16:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20061102181622.A8F334E00F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv22584 Modified Files: 0-9-3-all-souls'-day Log Message: Ugh. misspelled CLISP. From afuchs at common-lisp.net Thu Nov 2 18:37:04 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:37:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Webpage Message-ID: <20061102183704.535396D073@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Webpage In directory clnet:/tmp/cvs-serv25712/Webpage Modified Files: index.html Log Message: Haha. Souls', not Saints'. --- /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:08:26 1.16 +++ /project/mcclim/cvsroot/mcclim/Webpage/index.html 2006/11/02 18:37:04 1.17 @@ -54,13 +54,17 @@

Releases

- The most recent release of McCLIM is 0.9.3, in November 2006, available here: mcclim-0.9.3.tar.gz. It is also available via ASDF-INSTALL. + The most recent release of McCLIM is 0.9.3, in November 2006, + available here: mcclim-0.9.3.tar.gz. It + is also available via ASDF-INSTALL.

A snapshot of the CVS repository is made nightly.

Recent News

- 2006-11-02: McCLIM 0.9.3 "All Saints' Day" released. + 2006-11-02: McCLIM 0.9.3 "All Souls' Day" released.

@@ -120,7 +124,7 @@


-$Date: 2006/11/02 18:08:26 $ +$Date: 2006/11/02 18:37:04 $ From afuchs at common-lisp.net Thu Nov 2 18:39:22 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 13:39:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ReleaseNotes Message-ID: <20061102183922.5482A6D1B6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ReleaseNotes In directory clnet:/tmp/cvs-serv25817/ReleaseNotes Modified Files: 0-9-3-all-souls'-day Log Message: This is so wrong. Another 0.9.2 occurrence. From afuchs at common-lisp.net Thu Nov 2 19:41:11 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 14:41:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102194111.7B60E4F012@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3962 Modified Files: mcclim.asd Log Message: Increment asd file version to .3-dev --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 17:48:50 1.28 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 19:41:11 1.29 @@ -319,7 +319,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.3" + :version "0.9.4" :depends-on (:clim-looks)) ;;; CLIM-Examples depends on having at least one backend loaded. From afuchs at common-lisp.net Thu Nov 2 19:41:41 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 14:41:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102194141.E8FF250009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4022 Modified Files: mcclim.asd Log Message: (argh. save buffers) --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 19:41:11 1.29 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 19:41:41 1.30 @@ -319,7 +319,7 @@ ;;; The actual McCLIM system that people should to use in their ASDF ;;; package dependency lists. (defsystem :mcclim - :version "0.9.4" + :version "0.9.3-dev" :depends-on (:clim-looks)) ;;; CLIM-Examples depends on having at least one backend loaded. From afuchs at common-lisp.net Thu Nov 2 19:43:16 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 14:43:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102194316.F265D52002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4077 Removed Files: system.lisp Log Message: Remove the obsolete system.lisp file. From afuchs at common-lisp.net Thu Nov 2 19:45:26 2006 From: afuchs at common-lisp.net (afuchs) Date: Thu, 2 Nov 2006 14:45:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061102194526.8F9D552001@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4580 Modified Files: NEWS Log Message: News file entry for the system.lisp file. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/02 17:28:42 1.1 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/02 19:45:26 1.2 @@ -1,3 +1,6 @@ +* Changes in mcclim-0.9.4 relative to 0.9.3: +** cleanup: removed the obsolete system.lisp file. + * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the server search path From afuchs at common-lisp.net Sun Nov 5 00:30:28 2006 From: afuchs at common-lisp.net (afuchs) Date: Sat, 4 Nov 2006 19:30:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Experimental/freetype Message-ID: <20061105003028.C8C1F751A8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Experimental/freetype In directory clnet:/tmp/cvs-serv27539 Modified Files: freetype-package.lisp Log Message: Use cl:defpackage for the freetype package, no matter what. Maybe other package defns have the same problem. Will have to look into that. --- /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-package.lisp 2006/10/28 17:11:31 1.3 +++ /project/mcclim/cvsroot/mcclim/Experimental/freetype/freetype-package.lisp 2006/11/05 00:30:28 1.4 @@ -1,4 +1,4 @@ -(defpackage :mcclim-freetype +(cl:defpackage :mcclim-freetype (:use :climi :clim :clim-lisp) (:export :*freetype-font-path*) (:import-from #+(or cmu scl) :alien From dlichteblau at common-lisp.net Sun Nov 5 15:35:26 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 10:35:26 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061105153526.EF36416033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv5740 Modified Files: port.lisp Log Message: Magic number elimination #1: Remove the 100px default for mirror width and height. Old algorithm was: * Use cached sheet-mirror-region if present. * Else use keyword argument if given. * Else use default argument value 100. (The third code path was actually being used.) New algorithm: * Use keyword argument if given. * Else use cached sheet-mirror-region. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/10/29 08:29:46 1.123 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/11/05 15:35:26 1.124 @@ -337,7 +337,7 @@ mirror-region))) (defun realize-mirror-aux (port sheet - &key (width 100) (height 100) (x 0) (y 0) + &key width height (x 0) (y 0) (border-width 0) (border 0) (override-redirect :off) (map t) @@ -367,12 +367,10 @@ (pixel (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) color)) (window (xlib:create-window :parent (sheet-mirror (sheet-parent sheet)) - :width (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) - width) - :height (if (%sheet-mirror-region sheet) - (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) - height) + :width (or width + (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet)))) + :height (or height + (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet)))) :x (if (%sheet-mirror-transformation sheet) (round-coordinate (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) From dlichteblau at common-lisp.net Sun Nov 5 15:40:15 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 10:40:15 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061105154015.B2D7D1F000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6996 Modified Files: sheets.lisp Log Message: Magic number elimination #2: In sheet-mirror-region, do what the comment already claimed it does: Ask the backend for mirror sizes if the frontend does not have a cached value. Previously, width and height were returned as 65536, a completely bogus value. This was presumably because the CLX backend started out with the too-small 100x100 size. --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/05/05 10:24:02 1.51 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/11/05 15:40:15 1.52 @@ -671,17 +671,16 @@ ;; the server, since it is not under our control. ((or (null (sheet-parent sheet)) (null (sheet-parent (sheet-parent sheet)))) - (make-rectangle* 0 0 #x10000 #x10000) - #+nil (make-rectangle* 0 0 (port-mirror-width (port sheet) sheet) (port-mirror-height (port sheet) sheet))) (t ;; For other sheets just use the calculated value, saves a round trip. (or (%sheet-mirror-region sheet) - ;; XXX what to do if the sheet has no idea about its region? - ;; XXX can we consider calling sheet-mirror-region then an error? - (make-rectangle* 0 0 #x10000 #x10000) )))) + ;; ... unless we don't have it yet. + (make-rectangle* 0 0 + (port-mirror-width (port sheet) sheet) + (port-mirror-height (port sheet) sheet)) )))) (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin)) ;; XXX hm... From thenriksen at common-lisp.net Sun Nov 5 16:54:10 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 5 Nov 2006 11:54:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc/Guided-Tour Message-ID: <20061105165410.C4DE948149@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour In directory clnet:/tmp/cvs-serv17569/Doc/Guided-Tour Modified Files: guided-tour.tex Log Message: Change `run-top-level-frame' to `run-frame-top-level' and `color-edit' to `color-editor'. --- /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/03/21 15:00:24 1.4 +++ /project/mcclim/cvsroot/mcclim/Doc/Guided-Tour/guided-tour.tex 2006/11/05 16:54:10 1.5 @@ -980,12 +980,12 @@ \end{figure*} We can invoke the color-editor with the regular -\method{run-top-level-frame}/\method{make-application-frame} +\method{run-frame-top-level}/\method{make-application-frame} combination. \lstset{style=inlinestyle} \begin{lstlisting} -(run-top-level-frame - (make-application-frame 'color-edit)) +(run-frame-top-level + (make-application-frame 'color-editor)) \end{lstlisting} From dlichteblau at common-lisp.net Sun Nov 5 17:22:23 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 12:22:23 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061105172223.CDD1B16038@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv23372 Modified Files: clim-fix.lisp event.lisp gtk-ffi.lisp medium.lisp port.lisp Log Message: Low-flicker drawing: Double-buffer everything. * clim-fix.lisp (HANDLE-REPAINT, HIGHLIGHT-OUTPUT-RECORD-RECTANGLE): Use FORCE-OUTPUT on the SHEET instead of MEDIUM-FORCE-OUTPUT. * event.lisp (EXPOSE-HANDLER): If the mirror has a valid double buffering pixmap, has just blit the exposed rectangle to screen. Else, this must be the first redraw after initialization (A) or resize (B), so enqueue a window repaint event to get things going. For case A, clear the actual widget, since the frontend assumes mirrors to be filled with the background color if it never handles repaints on it. In case B, mark the pixmap as complete again. * gtk-ffi.lisp (gdk_window_invalidate_rect): New declaration. * medium.lisp (SYNC-SHEET): Mark the medium as dirty. (MEDIUM-FINISH-OUTPUT): Call medium-force-output after flushing the cairo surface. (MEDIUM-FORCE-OUTPUT): Remove the medium from the dirty table and invalidate the mirror. (INVALIDATE-MIRROR): For widget mirrors (with a double buffering pixmap), send an expose event. * port.lisp (*DOUBLE-BUFFERING-P*): New variable. (PORT): New slot DIRTY-MEDIUMS. (WIDGET-MIRROR): New slots PORT, BUFFERING-PIXMAP, BUFFERING-PIXMAP-P. (DRAWABLE-MIRROR): Additional accessor for the drawable slot, called MIRROR-REAL-DRAWABLE. ((MIRROR-REAL-DRAWABLE WIDGET-MIRROR)): Return the gdk window. (MIRROR-DRAWABLE): New method. Return or install the double buffering pixmap if *DOUBLE-BUFFERING-P* is enabled. Else return the real drawable. (REALIZE-WINDOW-MIRROR, REALIZE-MIRROR): Set the mirror's PORT slot. ((DESTROY-MIRROR MIRRORED-SHEET-MIXIN)): Free the double buffering pixmap. (RESET-MEDIUMS): Create a new double buffering pixmap for current size, copy over the old content, mark the pixmap as incomplete, and free the old one. (PORT-SET-MIRROR-REGION): Call RESET-MEDIUMS only after the resize has happened. (PORT-SET-MIRROR-TRANSFORMATION): No need to call RESET-MEDIUMS. (PORT-FORCE-OUTPUT): Call MEDIUM-FORCE-OUTPUT for all dirty mediums. Don't exit on X errors: * gtk-ffi.lisp (_gdk_error_warnings, _gdk_error_code, XGetErrorText): New declarations. * event.lisp (DRIBBLE-X-ERRORS): New function. (GTK-MAIN-ITERATION): Call DRIBBLE-X-ERRORS. * port.lisp (initialize-instance): Turn off `gdk-error-warnings', thereby disabling the GTk+'s "exit on error" behaviour. (PORT-FORCE-OUTPUT): Call DRIBBLE-X-ERRORS. Implement the weird pointer tracking code CLIM-CLX has: * port.lisp (PORT): New slot POINTER-GRAB-SHEET. (PORT-GRAB-POINTER): Set POINTER-GRAB-SHEET. (PORT-UNGRAB-POINTER): Clear POINTER-GRAB-SHEET if it is equal to the ungrabbing sheet. (DISTRIBUTE-EVENT :AROUND): Send events to the grabbing sheet no matter what. Misc: * event.lisp (ENTER-HANDLER): Set PORT-POINTER-SHEET manually, fixing a problem with the Drag and Drop demo. * medium.lisp (SYNC-TRANSFORMATION): Error out on invalid transformation -before- installing them into the cairo context. ((SYNC-INK FLIPPING-INK)): Removed unused binding of allocation size. * port.lisp (PORT-MIRROR-WIDTH, PORT-MIRROR-HEIGHT): Implemented. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/05/02 13:02:09 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/clim-fix.lisp 2006/11/05 17:22:23 1.5 @@ -36,8 +36,7 @@ ;; multiple times and looks like crap. This fixes it: (clim:with-drawing-options (m :clipping-region r) (clim:draw-design m r :ink clim:+background-ink+) - (call-next-method s r))) - (medium-force-output m))) + (call-next-method s r))))) ;; cairo hack: adjust rectangle coordinates by half a pixel each to avoid ;; anti-aliasing (and follow-up output artifacts) @@ -58,4 +57,5 @@ ;; FIXME: repaint the hit detection rectangle. It could be ;; bigger than ;; the bounding rectangle. - (repaint-sheet stream record)))))) + (repaint-sheet stream record))) + (force-output stream)))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/05/13 19:37:29 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 17:22:23 1.9 @@ -85,6 +85,15 @@ (pop (events-head port)) (car c))))) +(defun dribble-x-errors () + (unless (zerop *-gdk-error-code*) + (warn "Ignoring X error ~D: ~A" + *-gdk-error-code* + (cffi:with-foreign-pointer-as-string (buf 64) + #-(or win32 windows mswindows) + (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) + (setf *-gdk-error-code* 0))) + ;; thread-safe entry function (defun gtk-main-iteration (port &optional block) (with-gtk () @@ -92,7 +101,8 @@ (if block (gtk_main_iteration_do 1) (while (plusp (gtk_events_pending)) - (gtk_main_iteration_do 0)))))) + (gtk_main_iteration_do 0)))) + (dribble-x-errors))) (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) @@ -128,13 +138,29 @@ (define-signal noop-handler (widget event)) (define-signal expose-handler (widget event) - (enqueue - (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) - (gdk_window_clear_area (gtkwidget-gdkwindow widget) x y width height) - (make-instance 'window-repaint-event - :timestamp (get-internal-real-time) - :sheet (widget->sheet widget *port*) - :region (make-rectangle* x y (+ x width) (+ y height)))))) + (let* ((sheet (widget->sheet widget *port*)) + (mirror (climi::port-lookup-mirror *port* sheet))) + (unless + ;; fixme: this shouldn't happen + (typep mirror 'drawable-mirror) + (if (buffering-pixmap-dirty-p mirror) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (if (mirror-buffering-pixmap mirror) + (setf (buffering-pixmap-dirty-p mirror) nil) + (gdk_window_clear_area (gtkwidget-gdkwindow widget) + x y + width height)) + (enqueue + (make-instance 'window-repaint-event + :timestamp (get-internal-real-time) + :sheet (widget->sheet widget *port*) + :region (make-rectangle* x y (+ x width) (+ y height))))) + (cffi:with-foreign-slots ((x y width height) event gdkeventexpose) + (let* ((from (mirror-buffering-pixmap mirror)) + (to (gtkwidget-gdkwindow (mirror-widget mirror))) + (gc (gdk_gc_new to))) + (gdk_draw_drawable to gc from x y x y width height) + (gdk_gc_unref gc))))))) (defun gdkmodifiertype->modifier-state (state) (logior @@ -246,6 +272,11 @@ (define-signal enter-handler (widget event) (cffi:with-foreign-slots ((time state x y x_root y_root) event gdkeventcrossing) + ;; The frontend sets p-p-s for us, but apparently that sometimes + ;; happens too late, leaving NIL in the slot. Test case is the Drag and + ;; Drop demo. (Even weirder: Starting it from demodemo for a second time + ;; makes the problem go away, only the first invocation has this problem.) + (setf (climi::port-pointer-sheet *port*) (widget->sheet widget *port*)) (enqueue (make-instance 'pointer-enter-event :pointer 0 --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/05/13 19:37:29 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:22:23 1.8 @@ -120,6 +120,19 @@ (gdk_threads_leave))))) +;;; Error handling: + +(cffi:defcvar "_gdk_error_warnings" :int) +(cffi:defcvar "_gdk_error_code" :int) + +(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 @@ -730,6 +743,12 @@ (width :int) (height :int)) +(defcfun "gdk_window_invalidate_rect" + :void + (window :pointer) + (rect :pointer) + (childrenp :int)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/06/10 10:08:49 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 17:22:23 1.9 @@ -75,6 +75,8 @@ (sheet-region (medium-sheet medium))))))) (defun sync-sheet (medium) + (when (medium-sheet medium) ;ignore the metrik-medium + (setf (gethash medium (dirty-mediums (port medium))) t)) (when (or (null (cr medium)) (sheet-changed-behind-our-back-p medium)) (with-cairo-medium (medium) @@ -121,6 +123,10 @@ (setf tr (compose-transformations extra-transformation tr))) (multiple-value-bind (mxx mxy myx myy tx ty) (climi::get-transformation tr) + ;; Make sure not to hand transformations to cairo that it won't + ;; like, since debugging gets ugly once a cairo context goes + ;; into an error state: + (invert-transformation tr) (cairo_matrix_init matrix (df mxx) (df mxy) (df myx) (df myy) (df tx) (df ty)) @@ -238,21 +244,18 @@ (setf (flipping-original-cr medium) (cr medium)) (let* ((mirror (medium-mirror medium)) (drawable (mirror-drawable mirror))) - (cffi:with-foreign-slots ((allocation-width allocation-height) - (mirror-widget mirror) - gtkwidget) - (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) - (width (floor (bounding-rectangle-max-x region))) - (height (floor (bounding-rectangle-max-y region))) - (pixmap - (or (flipping-pixmap medium) - (setf (flipping-pixmap medium) - (gdk_pixmap_new drawable width height -1))))) - (setf (cr medium) (gdk_cairo_create pixmap)) - (setf (flipping-region medium) region) - (cairo_paint (cr medium)) - (sync-transformation medium) - (sync-ink medium +white+))))) + (let* ((region (climi::sheet-mirror-region (medium-sheet medium))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap + (or (flipping-pixmap medium) + (setf (flipping-pixmap medium) + (gdk_pixmap_new drawable width height -1))))) + (setf (cr medium) (gdk_cairo_create pixmap)) + (setf (flipping-region medium) region) + (cairo_paint (cr medium)) + (sync-transformation medium) + (sync-ink medium +white+)))) (defmethod sync-ink (medium new-value) (warn "SYNC-INK lost ~S." new-value)) @@ -639,12 +642,30 @@ (defmethod medium-finish-output ((medium gtkairo-medium)) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))))) + (medium-force-output medium)) (defmethod medium-force-output ((medium gtkairo-medium)) + (remhash medium (dirty-mediums (port medium))) (with-cairo-medium (medium) (when (cr medium) - (cairo_surface_flush (cairo_get_target (cr medium)))))) + (cairo_surface_flush (cairo_get_target (cr medium))) + (invalidate-mirror (medium-mirror medium) (medium-sheet medium))))) + +(defmethod invalidate-mirror ((mirror drawable-mirror) sheet) + (declare (ignore sheet))) + +(defmethod invalidate-mirror ((mirror widget-mirror) sheet) + (let* ((drawable (mirror-drawable mirror)) + (real-drawable (mirror-real-drawable mirror))) + (unless (cffi:pointer-eq drawable real-drawable) + (let* ((region (climi::sheet-mirror-region sheet)) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region)))) + (cffi:with-foreign-object (r 'gdkrectangle) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'width) width) + (setf (cffi:foreign-slot-value r 'gdkrectangle 'height) height) + (gdk_window_invalidate_rect real-drawable r 0)))))) (defmethod medium-beep ((medium gtkairo-medium)) ;; fixme: visual beep? --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/05/13 19:37:29 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 17:22:23 1.5 @@ -47,7 +47,9 @@ (events-head :accessor events-head) (events-tail :accessor events-tail) (widgets->sheets :initform (make-hash-table) :accessor widgets->sheets) - (metrik-medium :accessor metrik-medium))) + (dirty-mediums :initform (make-hash-table) :accessor dirty-mediums) + (metrik-medium :accessor metrik-medium) + (pointer-grab-sheet :accessor pointer-grab-sheet :initform nil))) ;;;(defmethod print-object ((object gtkairo-port) stream) ;;; (print-unreadable-object (object stream :identity t :type t) @@ -72,7 +74,8 @@ (slot-value port 'climi::frame-managers)) (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) - (gdk_threads_init)) + (gdk_threads_init) + (setf *-gdk-error-warnings* 0)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten @@ -106,8 +109,13 @@ (region :initform nil :accessor mirror-region))) (defclass widget-mirror (mirror) - ((widget :initarg :widget :accessor mirror-widget) - (mediums :initform '() :accessor mirror-mediums))) + ((port :initarg :port :accessor mirror-port) + (widget :initarg :widget :accessor mirror-widget) + (mediums :initform '() :accessor mirror-mediums) + (buffering-pixmap-dirty-p + :initform t + :accessor buffering-pixmap-dirty-p) + (buffering-pixmap :initform nil :accessor mirror-buffering-pixmap))) (defclass window-mirror (widget-mirror) ((window :initarg :window :accessor mirror-window))) @@ -116,12 +124,42 @@ ((fixed :initarg :fixed :accessor mirror-fixed))) (defclass drawable-mirror (mirror) - ((drawable :initarg :drawable :accessor mirror-drawable) + ((drawable :initarg :drawable + :accessor mirror-drawable + :accessor mirror-real-drawable) (mediums :initform '() :accessor mirror-mediums))) -(defmethod mirror-drawable ((mirror widget-mirror)) +(defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) +(defvar *double-buffering-p* t) + +(defparameter *old-frontend-size-hack* t) + +(defmethod mirror-drawable ((mirror widget-mirror)) + (if *double-buffering-p* + (or (mirror-buffering-pixmap mirror) + (setf (mirror-buffering-pixmap mirror) + (let* ((*old-frontend-size-hack* nil) + (window (mirror-real-drawable mirror)) + (region (climi::sheet-mirror-region + (climi::port-lookup-sheet + (mirror-port mirror) + mirror))) + (width (floor (bounding-rectangle-max-x region))) + (height (floor (bounding-rectangle-max-y region))) + (pixmap (gdk_pixmap_new window width height -1)) + (cr (gdk_cairo_create pixmap))) + (cairo_set_source_rgba cr + 1.0d0 + 1.0d0 + 1.0d0 + 1.0d0) + (cairo_paint cr) + (cairo_destroy cr) + pixmap))) + (mirror-real-drawable mirror))) + (defun widget->sheet (widget port) (gethash (cffi:pointer-address widget) (widgets->sheets port))) @@ -160,7 +198,10 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'window-mirror :window window :widget widget))) + (mirror (make-instance 'window-mirror + :port port + :window window + :widget widget))) (gtk_window_set_title window (frame-pretty-name (pane-frame sheet))) (setf (widget->sheet widget port) sheet) (setf (widget->sheet window port) sheet) @@ -216,7 +257,7 @@ (widget (gtk_fixed_new)) (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) - (mirror (make-instance 'widget-mirror :widget widget))) + (mirror (make-instance 'widget-mirror :port port :widget widget))) (setf (widget->sheet widget port) sheet) ;; Das machen wir uns mal einfach und geben jedem Widget sein eigenes ;; Fenster, dann haben wir naemlich das Koordinatensystem und Clipping @@ -266,7 +307,10 @@ (width (round-coordinate (space-requirement-width q))) (height (round-coordinate (space-requirement-height q))) (mirror - (make-instance 'native-widget-mirror :fixed fixed :widget widget))) + (make-instance 'native-widget-mirror + :port port + :fixed fixed + :widget widget))) (setf (widget->sheet fixed port) sheet) (setf (widget->sheet widget port) sheet) (gtk_fixed_set_has_window fixed 1) @@ -376,6 +420,8 @@ (let ((mirror (climi::port-lookup-mirror port sheet))) (destroy-mediums mirror) (gtk_widget_destroy (mirror-widget mirror)) + (when (mirror-buffering-pixmap mirror) + (gdk_drawable_unref (mirror-drawable mirror))) (climi::port-unregister-mirror port sheet mirror) (setf (widget->sheet (mirror-widget mirror) port) nil)))) @@ -408,15 +454,25 @@ (defun reset-mediums (mirror) (dolist (medium (mirror-mediums mirror)) - (setf (cr medium) nil))) + (setf (cr medium) nil)) + (when (mirror-buffering-pixmap mirror) + (let* ((old (mirror-buffering-pixmap mirror)) + (new (progn + (setf (mirror-buffering-pixmap mirror) nil) + (mirror-drawable mirror))) + (gc (gdk_gc_new new))) + (gdk_draw_drawable new gc old 0 0 0 0 -1 -1) + (gdk_gc_unref gc) + (gdk_drawable_unref old)) + (setf (buffering-pixmap-dirty-p mirror) t))) (defmethod port-set-mirror-region ((port gtkairo-port) (mirror window-mirror) mirror-region) (with-gtk () - (reset-mediums mirror) (gtk_window_resize (mirror-window mirror) (floor (bounding-rectangle-max-x mirror-region)) (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror) ;; Nanu, ohne die Geometrie hier zu korrigieren kann das Fenster nur ;; vergroessert, nicht aber wieder verkleinert werden. (cffi:with-foreign-object (geometry 'gdkgeometry) @@ -432,11 +488,11 @@ (unless (and (mirror-region mirror) (region-equal (mirror-region mirror) mirror-region)) (with-gtk () - (reset-mediums mirror) (gtk_widget_set_size_request (mirror-widget mirror) (floor (bounding-rectangle-max-x mirror-region)) - (floor (bounding-rectangle-max-y mirror-region)))) + (floor (bounding-rectangle-max-y mirror-region))) + (reset-mediums mirror)) (setf (mirror-region mirror) mirror-region))) (defmethod port-set-mirror-region @@ -452,7 +508,8 @@ (with-gtk () (multiple-value-bind (x y) (transform-position mirror-transformation 0 0) - (gtk_window_move (mirror-window mirror) (floor x) (floor y))))) + (gtk_window_move (mirror-window mirror) (floor x) (floor y))) + (reset-mediums mirror))) (defmethod port-set-mirror-transformation ((port gtkairo-port) (mirror mirror) mirror-transformation) @@ -578,10 +635,28 @@ (error "port-string-width called, what now?")) (defmethod port-mirror-width ((port gtkairo-port) sheet) - (error "port-mirror-width called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'width)))) (defmethod port-mirror-height ((port gtkairo-port) sheet) - (error "port-mirror-height called, we thought the frontend doesn't do that")) + (if *old-frontend-size-hack* + #x10000 + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'height)))) + +(defmethod port-mirror-width ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-width sheet)) + +(defmethod port-mirror-height ((port gtkairo-port) (sheet gtkairo-graft)) + (graft-height sheet)) (defmethod graft ((port gtkairo-port)) (first (climi::port-grafts port))) @@ -655,11 +730,15 @@ (defmethod port-force-output ((port gtkairo-port)) (with-gtk () + (loop + for medium being each hash-key in (dirty-mediums port) + do (medium-force-output medium)) (gdk_display_flush (gdk_display_get_default)) ;; Don't know whether p-f-o is actually meant to XSync, which is ;; what gdk_flush does. But it seems useful to have _some_ function ;; for this, so let's use p-f-o until we find a better one. - (gdk_flush))) + (gdk_flush) + (dribble-x-errors))) ;; FIXME: What happens when CLIM code calls tracking-pointer recursively? (defmethod port-grab-pointer ((port gtkairo-port) pointer sheet) @@ -680,15 +759,21 @@ ;;; (tr :timeout!) ;;; (with-gtk () ;;; (gdk_pointer_ungrab GDK_CURRENT_TIME)))) - (zerop status)))) + (when (zerop status) + (setf (pointer-grab-sheet port) sheet))))) (defmethod port-ungrab-pointer ((port gtkairo-port) pointer sheet) (declare (ignore pointer sheet)) (with-gtk () - (gdk_pointer_ungrab GDK_CURRENT_TIME))) + (when (eq (pointer-grab-sheet port) sheet) + (gdk_pointer_ungrab GDK_CURRENT_TIME) + (setf (pointer-grab-sheet port) nil)))) (defmethod distribute-event :around ((port gtkairo-port) event) - (call-next-method)) + (let ((grab-sheet (pointer-grab-sheet port))) + (if grab-sheet + (queue-event grab-sheet event) + (call-next-method)))) (defmethod set-sheet-pointer-cursor ((port gtkairo-port) sheet cursor) ()) From dlichteblau at common-lisp.net Sun Nov 5 17:29:11 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 12:29:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061105172911.491AC16039@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv23936 Modified Files: cairo-ffi.lisp gtk-ffi.lisp Log Message: Patch by Douglas Crosher, <4543F391.9000708 at scieneer.com> --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/10/28 17:49:24 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/cairo-ffi.lisp 2006/11/05 17:29:11 1.7 @@ -41,14 +41,8 @@ , at args) (defun ,wrapper ,argnames (multiple-value-prog1 - ;; FIXME: This should probably go into with-cairo-floats. - ;; (see http://www.ircbrowse.com/channel/lisp/20061028?utime=3371045114#utime_requested) - #-scl (,actual , at argnames) - #+scl - (ext:with-float-traps-masked (:underflow :overflow :inexact - :divide-by-zero :invalid) - (,actual , at argnames)) - (let ((status (cairo_status ,(car argnames)))) + (,actual , at argnames) + (let ((status (cairo_status ,(car argnames)))) (unless (eq status :success) (error "~A returned with status ~A" ,name status)))))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:22:23 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:29:11 1.9 @@ -85,12 +85,23 @@ ;; reset all options afterwards, I get lisp errors like f-p-i-o for, say, ;; (ATAN -13 13/2) in McCLIM. Isn't SBCL responsible for calling C code ;; with the with the modes C code expects? Or does cairo change them? +#+sbcl (defmacro with-cairo-floats ((&optional) &body body) `(unwind-protect (progn - #+sbcl (sb-int:set-floating-point-modes :traps nil) + (sb-int:set-floating-point-modes :traps nil) , at body) - #+sbcl (apply #'sb-int:set-floating-point-modes *normal-modes*))) + (apply #'sb-int:set-floating-point-modes *normal-modes*))) + +#+(or scl cmu) +(defmacro with-cairo-floats ((&optional) &body body) + `(ext:with-float-traps-masked + (:underflow :overflow :inexact :divide-by-zero :invalid) + , at body)) + +#-(or scl cmu sbcl) +(defmacro with-cairo-floats ((&optional) &body body) + `(progn , at body)) ;; Note: There's no need for locking in single threaded mode for most ;; functions, except that the main loop functions try to release the From dlichteblau at common-lisp.net Sun Nov 5 18:22:08 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 13:22:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061105182208.0E0E67D002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv32102 Modified Files: mcclim.asd Log Message: update gtkairo build order --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/02 19:41:41 1.30 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 18:22:07 1.31 @@ -270,12 +270,12 @@ (:file "package") (:file "gtk-ffi") (:file "cairo-ffi") + (:file "graft") (:file "port") (:file "event") (:file "keysymdef") (:file "medium") (:file "pixmap") - (:file "graft") (:file "frame-manager") (:file "gadgets"))))) From dlichteblau at common-lisp.net Sun Nov 5 18:43:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 13:43:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061105184319.B6824C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv2828 Modified Files: event.lisp gtk-ffi.lisp port.lisp Log Message: restore build on windows --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 17:22:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 18:43:19 1.10 @@ -86,11 +86,11 @@ (car c))))) (defun dribble-x-errors () + #-(or win32 windows mswindows) (unless (zerop *-gdk-error-code*) (warn "Ignoring X error ~D: ~A" *-gdk-error-code* (cffi:with-foreign-pointer-as-string (buf 64) - #-(or win32 windows mswindows) (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) (setf *-gdk-error-code* 0))) @@ -107,6 +107,7 @@ (defmethod get-next-event ((port gtkairo-port) &key wait-function (timeout nil)) (declare (ignore wait-function)) + #-clim-mp (port-force-output port) (gtk-main-iteration port) (cond ((dequeue port)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 17:29:11 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 18:43:19 1.10 @@ -136,6 +136,7 @@ (cffi:defcvar "_gdk_error_warnings" :int) (cffi:defcvar "_gdk_error_code" :int) +#-(or win32 mswindows windows) (cffi:defcfun "XGetErrorText" :void (display :pointer) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 17:22:23 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 18:43:19 1.6 @@ -75,6 +75,7 @@ (when (zerop *g-threads-got-initialized*) (g_thread_init (cffi:null-pointer)) (gdk_threads_init) + #-(or win32 windows mswindows) (setf *-gdk-error-warnings* 0)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben From dlichteblau at common-lisp.net Sun Nov 5 18:49:13 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 13:49:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061105184913.E4F0614007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3334 Modified Files: BUGS medium.lisp Log Message: Fixed bugs 6b and 7b. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/06/10 10:08:49 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/11/05 18:49:13 1.12 @@ -30,7 +30,7 @@ (FIXED) 6. [Address book didn't work on windows.] -6b. +(FIXED) 6b. On windows, something draws gray ink over the buttons in demodemo after expose events. This should not happen, since the gtkbuttons are in a gtkfixed with its own window. Thorough double buffering @@ -44,7 +44,7 @@ flipping ink takes time proportional to the with the size of the window, not with the size of the shape being drawn -7b. +(FIXED) 7b. (problem appears to be gone with double buffering) flipping ink pixmap caching is broken on windows 7c. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 17:22:23 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 18:49:13 1.10 @@ -236,9 +236,7 @@ (cairo_surface_mark_dirty to-surface)) (cairo_destroy (cr medium)) (setf (cr medium) (flipping-original-cr medium)) - (setf (flipping-original-cr medium) nil) - #+(or win32 mswindows windows) ;fixme - (dispose-flipping-pixmap medium)) + (setf (flipping-original-cr medium) nil)) (defmethod sync-ink (medium (design climi::standard-flipping-ink)) (setf (flipping-original-cr medium) (cr medium)) From dlichteblau at common-lisp.net Sun Nov 5 19:00:54 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 14:00:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061105190054.7751F24053@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv5752 Modified Files: mcclim.asd Log Message: Easier Gtkairo building on Windows: If the :GTKAIRO feature is set, disable the dependency from CLIM-LOOKS to CLIM-CLX. This way, the default is to load CLIM-CLX as usual, but users who explicitly request Gtkairo can build without CLX and sb-bsd-sockets. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 18:22:07 1.31 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 19:00:54 1.32 @@ -295,7 +295,8 @@ :depends-on (:clim :clim-postscript ;; If we're on an implementation that ships CLX, use ;; it. Same if the user has loaded CLX already. - #+(or sbcl scl openmcl ecl clx allegro) :clim-clx + #+(and (or sbcl scl openmcl ecl clx allegro) (not gtkairo)) + :clim-clx #+gl :clim-opengl ;; OpenMCL and MCL support the beagle backend (native ;; OS X look&feel on OS X). @@ -309,7 +310,8 @@ ;; null backend :clim-null ) - :components ((:file "Looks/pixie" + :components (#-gtkairo + (:file "Looks/pixie" :pathname #.(make-pathname :directory '(:relative "Looks") :name "pixie" :type "lisp")))) ;;; name of :clim-clx-user chosen by mikemac for no good reason From dlichteblau at common-lisp.net Sun Nov 5 21:23:12 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 5 Nov 2006 16:23:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061105212312.C61352E1C5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv32229 Modified Files: gtk-ffi.lisp medium.lisp port.lisp Log Message: Make gsharp pretty. * gtk-ffi.lisp (gdk_draw_rectangle, gdk_gc_set_rgb_fg_color): New declarations. * medium.lisp (medium-draw-point*, medium-draw-points*): Draw the line in a 45 deg angle, resulting in a fully saturated color. * port.lisp ((realize-mirror pixmap)): Clear the pixmap using white color. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 18:43:19 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 21:23:11 1.11 @@ -602,6 +602,21 @@ (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 ) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 18:49:13 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/medium.lisp 2006/11/05 21:23:12 1.11 @@ -446,7 +446,7 @@ (setf x (df x)) (setf y (df y)) (cairo_move_to cr x y) - (cairo_line_to cr (+ x (/ x (expt 2 16))) y) + (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))) (defmethod medium-draw-points* ((medium gtkairo-medium) coord-seq) @@ -462,7 +462,7 @@ (let ((x (df (elt coord-seq (+ i 0)))) (y (df (elt coord-seq (+ i 1))))) (cairo_move_to cr x y) - (cairo_line_to cr (+ x (/ x (expt 2 16))) y) + (cairo_line_to cr (+ x 0.5) (+ y 0.5)) (cairo_stroke cr)))))) (defmethod medium-draw-line* ((medium gtkairo-medium) x1 y1 x2 y2) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 18:43:19 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 21:23:12 1.7 @@ -379,12 +379,20 @@ (let* ((drawable (mirror-drawable (sheet-direct-mirror (climi::pixmap-sheet pixmap-sheet)))) - (pixmap - (gdk_pixmap_new drawable - (round (pixmap-width pixmap-sheet)) - (round (pixmap-height pixmap-sheet)) - -1)) - (mirror (make-instance 'drawable-mirror :drawable pixmap))) + (w (round (pixmap-width pixmap-sheet))) + (h (round (pixmap-height pixmap-sheet))) + (pixmap (gdk_pixmap_new drawable w h -1)) + (mirror (make-instance 'drawable-mirror :drawable pixmap)) + (gc (gdk_gc_new pixmap))) + (cffi:with-foreign-object (c 'gdkcolor) + (setf (cffi:foreign-slot-value c 'gdkcolor 'pixel) 0) + (setf (values (cffi:foreign-slot-value c 'gdkcolor 'r) + (cffi:foreign-slot-value c 'gdkcolor 'g) + (cffi:foreign-slot-value c 'gdkcolor 'b)) + (values 65535 65535 65535)) + (gdk_gc_set_rgb_fg_color gc c)) + (gdk_draw_rectangle pixmap gc 1 0 0 w h) + (gdk_gc_unref gc) (climi::port-register-mirror port pixmap-sheet mirror) mirror))) From thenriksen at common-lisp.net Wed Nov 8 01:09:18 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:09:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061108010918.D40F660034@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24623/ESA Log Message: Directory /project/mcclim/cvsroot/mcclim/ESA added to the repository From thenriksen at common-lisp.net Wed Nov 8 01:10:16 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:10:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061108011016.840C3671A5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv24784/ESA Added Files: utils.lisp packages.lisp esa.lisp esa.asd esa-io.lisp esa-command-parser.lisp esa-buffer.lisp colors.lisp Log Message: Committed ESA. --- /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/utils.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: ESA-UTILS -*- ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Miscellaneous utilities used in Climacs. (in-package :esa-utils) ;;; Cribbed from Paul Graham (defmacro with-gensyms (syms &body body) `(let ,(mapcar #'(lambda (s) `(,s (gensym))) syms) , at body)) ;;; Cribbed from PCL by Seibel (defmacro once-only ((&rest names) &body body) (let ((gensyms (loop for n in names collect (gensym)))) `(let (,@(loop for g in gensyms collect `(,g (gensym)))) `(let (,,@(loop for g in gensyms for n in names collect ``(,,g ,,n))) ,(let (,@(loop for n in names for g in gensyms collect `(,n ,g))) , at body))))) (defun unlisted (obj &optional (fn #'first)) (if (listp obj) (funcall fn obj) obj)) (defun fully-unlisted (obj &optional (fn #'first)) (if (listp obj) (fully-unlisted (funcall fn obj)) obj)) (defun listed (obj) (if (listp obj) obj (list obj))) (defun list-aref (list &rest subscripts) (if subscripts (apply #'list-aref (nth (first subscripts) list) (rest subscripts)) list)) ;;; Cribbed from McCLIM. (defun check-letf-form (form) (assert (and (listp form) (= 2 (length form))))) (defun valueify (list) (if (and (consp list) (endp (rest list))) (first list) `(values , at list))) (defmacro letf ((&rest forms) &body body &environment env) "LETF ({(Place Value)}*) Declaration* Form* During evaluation of the Forms, SETF the Places to the result of evaluating the Value forms. The places are SETF-ed in parallel after all of the Values are evaluated." (mapc #'check-letf-form forms) (let* (init-let-form save-old-values-setf-form new-values-set-form old-values-set-form update-form) (loop for (place new-value) in forms for (vars vals store-vars writer-form reader-form) = (multiple-value-list (get-setf-expansion place env)) for old-value-names = (mapcar (lambda (var) (declare (ignore var)) (gensym)) store-vars) nconc (mapcar #'list vars vals) into temp-init-let-form nconc (copy-list store-vars) into temp-init-let-form nconc (copy-list old-value-names) into temp-init-let-form nconc `(,(valueify old-value-names) ,reader-form) into temp-save-old-values-setf-form nconc `(,(valueify store-vars) ,new-value) into temp-new-values-set-form nconc `(,(valueify store-vars) ,(valueify old-value-names)) into temp-old-values-set-form collect writer-form into temp-update-form finally (setq init-let-form temp-init-let-form save-old-values-setf-form temp-save-old-values-setf-form new-values-set-form temp-new-values-set-form old-values-set-form temp-old-values-set-form update-form (cons 'progn temp-update-form))) `(let* ,init-let-form (setf , at save-old-values-setf-form) (unwind-protect (progn (setf , at new-values-set-form) ,update-form (progn , at body)) (setf , at old-values-set-form) ,update-form)))) (defun invoke-with-dynamic-bindings-1 (bindings continuation) (let ((old-values (mapcar #'(lambda (elt) (symbol-value (first elt))) bindings))) (unwind-protect (progn (mapcar #'(lambda (elt) (setf (symbol-value (first elt)) (funcall (second elt)))) bindings) (funcall continuation)) (mapcar #'(lambda (elt value) (setf (symbol-value (first elt)) value)) bindings old-values)))) (defmacro invoke-with-dynamic-bindings ((&rest bindings) &body body) `(invoke-with-dynamic-bindings-1 ,(loop for (symbol expression) in bindings collect (list `',symbol `#'(lambda () ,expression))) #'(lambda () , at body))) ;;; XXX This is currently broken with respect to declarations (defmacro letf* ((&rest forms) &body body) (if (null forms) `(locally , at body) `(letf (,(car forms)) (letf* (,(cdr forms)) , at body)))) (defun display-string (string) (with-output-to-string (result) (loop for char across string do (cond ((graphic-char-p char) (princ char result)) ((char= char #\Space) (princ char result)) (t (prin1 char result)))))) (defun object-equal (x y) "Case insensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char-equal x y)) (eql x y))) (defun object= (x y) "Case sensitive equality that doesn't require characters" (if (characterp x) (and (characterp y) (char= x y)) (eql x y))) (defun no-upper-p (string) "Does STRING contain no uppercase characters" (notany #'upper-case-p string)) (defun case-relevant-test (string) "Returns a test function based on the search-string STRING. If STRING contains no uppercase characters the test is case-insensitive, otherwise it is case-sensitive." (if (no-upper-p string) #'object-equal #'object=)) (defun remove-keywords (arg-list keywords) (let ((clean-tail arg-list)) ;; First, determine a tail in which there are no keywords to be removed. (loop for arg-tail on arg-list by #'cddr for (key) = arg-tail do (when (member key keywords :test #'eq) (setq clean-tail (cddr arg-tail)))) ;; Cons up the new arg list until we hit the clean-tail, then nconc that on ;; the end. (loop for arg-tail on arg-list by #'cddr for (key value) = arg-tail if (eq arg-tail clean-tail) nconc clean-tail and do (loop-finish) else if (not (member key keywords :test #'eq)) nconc (list key value) end))) (defmacro with-keywords-removed ((var keywords &optional (new-var var)) &body body) "binds NEW-VAR (defaults to VAR) to VAR with the keyword arguments specified in KEYWORDS removed." `(let ((,new-var (remove-keywords ,var ',keywords))) , at body))--- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- ;;; (c) copyright 2004-2006 by ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2006 by ;;; Troels Henriksen (athas at sigkill.dk) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Package definitions for ESA. (defpackage :esa-utils (:use :clim-lisp) (:export #:with-gensyms #:once-only #:unlisted #:fully-unlisted #:listed #:list-aref #:letf #:letf* #:display-string #:object-equal #:object= #:no-upper-p #:case-relevant-test #:with-keywords-removed #:invoke-with-dynamic-bindings-1 #:invoke-with-dynamic-bindings)) (defpackage :esa (:use :clim-lisp :clim :esa-utils) (:export #:buffers #:frame-current-buffer #:current-buffer #:*current-buffer* #:windows #:frame-current-window #:current-window #:*current-window* #:*previous-command* #:*minibuffer* #:minibuffer #:minibuffer-pane #:display-message #:with-minibuffer-stream #:esa-pane-mixin #:previous-command #:info-pane #:master-pane #:esa-frame-mixin #:recordingp #:executingp #:*esa-abort-gestures* #:*numeric-argument-p* #:*current-gesture* #:*command-processor* #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:macrorecord-processed-gestures-mixin #:asynchronous-command-processor #:command-loop-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:*extended-command-prompt* #:define-esa-top-level #:esa-top-level #:simple-command-loop #:convert-to-gesture #:gesture-name #:global-esa-table #:keyboard-macro-table #:help-table #:help-stream #:set-key #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p #:universal-argument #:meta-minus)) (defpackage :esa-buffer (:use :clim-lisp :clim :esa :esa-utils) (:export #:frame-make-buffer-from-stream #:make-buffer-from-stream #:frame-save-buffer-to-stream #:save-buffer-to-stream #:filepath #:name #:needs-saving #:file-write-time #:file-saved-p #:esa-buffer-mixin #:frame-make-new-buffer #:make-new-buffer #:read-only-p)) (defpackage :esa-io (:use :clim-lisp :clim :esa :esa-buffer :esa-utils) (:export #:frame-find-file #:find-file #:frame-find-file-read-only #:find-file-read-only #:frame-set-visited-file-name #:set-visited-filename #:frame-save-buffer #:save-buffer #:frame-write-buffer #:write-buffer #:esa-io-table)) #-(or mcclim building-mcclim) (defpackage :clim-extensions (:use :clim-lisp :clim) (:export #:+blue-violet+ #:+dark-blue+ #:+dark-green+ #:+dark-violet+ #:+gray50+ #:+gray85+ #:+maroon+ #:+purple+))--- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/08 01:10:16 1.1 ;;; -*- Mode: Lisp; Package: ESA -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Emacs-Style Appication (in-package :esa) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Querying ESAs. (defgeneric buffers (application-frame) (:documentation "Return a list of all the buffers of the application.")) (defgeneric frame-current-buffer (application-frame) (:documentation "Return the current buffer of APPLICATION-FRAME.") (:method ((frame application-frame)) nil)) (defvar *current-buffer* nil "When a command is being executed, the current buffer.") (defun current-buffer () "Return the current buffer of `*application-frame*'." (frame-current-buffer *application-frame*)) (defgeneric windows (application-frame) (:documentation "Return a list of all the windows of the application.") (:method ((application-frame application-frame)) '())) (defgeneric frame-current-window (application-frame) (:documentation "Return the current window of APPLICATION-FRAME.") (:method ((frame application-frame)) (first (windows frame)))) (defvar *current-window* nil "When a command is being executed, the current window.") (defun current-window () "Return the current window of `*application-frame*'." (frame-current-window *application-frame*)) (defvar *previous-command* nil "When a command is being executed, the command previously executed by the current frame.") ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Info pane, a pane that displays some information about another pane (defclass info-pane (application-pane) ((master-pane :initarg :master-pane :reader master-pane)) (:default-initargs :background +gray85+ :scroll-bars nil :borders nil)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Minibuffer pane (defgeneric minibuffer (application-frame) (:documentation "Return the minibuffer of `application-frame'.")) (defvar *minibuffer* nil "The minibuffer pane of the running application.") (defvar *minimum-message-time* 1 "The minimum number of seconds a minibuffer message will be displayed." ) (defclass minibuffer-pane (application-pane) ((message :initform nil :accessor message :documentation "An output record containing whatever message is supposed to be displayed in the minibuffer.") (message-time :initform 0 :accessor message-time :documentation "The universal time at which the current message was set.")) (:default-initargs :scroll-bars nil :display-function 'display-minibuffer [1505 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa.asd 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa.asd 2006/11/08 01:10:16 1.1 [1543 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/08 01:10:16 1.1 [1899 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-command-parser.lisp 2006/11/08 01:10:16 1.1 [2020 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/esa-buffer.lisp 2006/11/08 01:10:16 1.1 [2074 lines skipped] --- /project/mcclim/cvsroot/mcclim/ESA/colors.lisp 2006/11/08 01:10:16 NONE +++ /project/mcclim/cvsroot/mcclim/ESA/colors.lisp 2006/11/08 01:10:16 1.1 [2108 lines skipped] From thenriksen at common-lisp.net Wed Nov 8 01:12:18 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:12:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20061108011218.ADD85671A5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24849/cl-automaton Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/cl-automaton added to the repository From thenriksen at common-lisp.net Wed Nov 8 01:12:24 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:12:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Persistent Message-ID: <20061108011224.7234A671A5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv24888/Persistent Log Message: Directory /project/mcclim/cvsroot/mcclim/Drei/Persistent added to the repository From thenriksen at common-lisp.net Wed Nov 8 01:15:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:15:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/cl-automaton Message-ID: <20061108011532.ACA96671A6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/cl-automaton In directory clnet:/tmp/cvs-serv24994/Drei/cl-automaton Added Files: state-and-transition.lisp state-and-transition-test.lisp regexp.lisp regexp-test.lisp eqv-hash.txt eqv-hash.lisp eqv-hash-test.lisp automaton.lisp automaton.asd automaton-test.lisp automaton-test.asd automaton-test-package.lisp automaton-package.lisp Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller (in-package :automaton) (defconstant +min-char-code+ 0) (defconstant +max-char-code+ (1- char-code-limit)) ;;; In Allegro (for one), defconstants aren't available as values at compile ;;; time. (deftype char-code-type () `(integer 0 ,(1- char-code-limit))) (defclass state () ((accept :initform nil :accessor accept :type boolean) (transitions :accessor transitions :type generalized-hash-table) (num :initform 0 :accessor num :type fixnum) (id :accessor id :type fixnum) (next-id :allocation :class :initform -1 :accessor next-id :type fixnum))) (declaim (special *state-ht*)) (defun state-equal (s1 s2) ; for testing, assuming minimization (multiple-value-bind (se se-p) (gethash (cons s1 s2) *state-ht*) ; TODO: consider (cons s2 s1), too (if se-p se (setf (gethash (cons s1 s2) *state-ht*) t ; bound recursion temporarily (gethash (cons s1 s2) *state-ht*) (and (eq (accept s1) (accept s2)) (transitions-equal (transitions s1) (transitions s2))))))) (declaim (special *to-first*)) (defun transitions-equal (ts1 ts2) ; for testing, assuming minimization (let* ((*to-first* nil) (tss1 (sort (with-ht-collect (t1 nil) ts1 t1) #'transition<)) (tss2 (sort (with-ht-collect (t2 nil) ts2 t2) #'transition<))) (flet ((%transition-equal (t1 t2) (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) t1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) t2 (and (= minc1 minc2) (= maxc1 maxc2) (state-equal to1 to2)))))) (and (= (length tss1) (length tss2)) (loop for t1 in tss1 and t2 in tss2 always (%transition-equal t1 t2)))))) (defclass state-pair () ((s :initarg :s :accessor s :type (or null state)) (s1 :initarg :s1 :accessor s1 :type state) (s2 :initarg :s2 :accessor s2 :type state))) (defclass transition () ((minc :initarg :minc :accessor minc :type char-code-type) (maxc :initarg :maxc :accessor maxc :type char-code-type) (to :initarg :to :accessor to :type state))) (defclass state-set () ((ht :initform (make-hash-table) :initarg :ht :accessor ht :type hash-table))) (defmethod initialize-instance :after ((s state) &rest initargs) (declare (ignorable initargs)) (with-slots (transitions id next-id) s (setf transitions (make-generalized-hash-table +equalp-key-situation+) id (incf next-id)))) (defmethod initialize-instance :after ((tr transition) &rest initargs) (declare (ignorable initargs)) (with-slots (minc maxc to) tr (cond ((not minc) (assert maxc nil "MINC or MAXC required") (setf minc maxc)) ((not maxc) (assert minc nil "MINC or MAXC required") (setf maxc minc)) ((> minc maxc) (rotatef minc maxc))) (assert to nil "TO required"))) (defmethod eqv ((sp1 state-pair) (sp2 state-pair) (s (eql +equalp-key-situation+))) (and (eq (s1 sp1) (s1 sp2)) (eq (s2 sp1) (s2 sp2)))) (defmethod hash ((sp state-pair) (s (eql +equalp-key-situation+))) "Returns the hash code for state-pair SP." (the fixnum (mod (+ (sxhash (s1 sp)) (sxhash (s2 sp))) most-positive-fixnum))) (defmethod eqv ((tr1 transition) (tr2 transition) (s (eql +equalp-key-situation+))) "Returns true if transitions TR1 and TR2 have equal interval and same (eq) destination state." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (and (= minc1 minc2) (= maxc1 maxc2) (eq to1 to2))))) (defmethod hash ((tr transition) (s (eql +equalp-key-situation+))) "Returns the hash code for transition TR." (with-slots (minc maxc) tr (the fixnum (mod (+ (* 2 minc) (* 3 maxc)) most-positive-fixnum)))) (defmethod clone ((tr transition)) "Returns a clone of TR." (with-slots (minc maxc to) tr (make-instance 'transition :minc minc :maxc maxc :to to))) (defmethod eqv ((ss1 state-set) (ss2 state-set) (s (eql +equalp-key-situation+))) "Returns true if state-set objects SS1 and SS2 contain the same (eql) state objects." (and (= (hash-table-count (ht ss1)) (hash-table-count (ht ss2))) (loop for st being the hash-key of (ht ss1) always (gethash st (ht ss2))))) (defmethod hash ((ss state-set) (s (eql +equalp-key-situation+))) "Returns the hash code for state-set SS." (the fixnum (mod (loop for st being the hash-key of (ht ss) sum (sxhash st)) most-positive-fixnum))) (defvar *escape-unicode-chars* nil) ; true may be useful in Slime (defun escaped-char (c) (if (or (not *escape-unicode-chars*) (and (<= #x21 c #x7e) (/= c (char-code #\\)))) (code-char c) (format nil "\\u~4,'0O" c))) (defmethod print-object ((st state) s) (with-slots (accept transitions num) st (format s "~@~:>" num (if accept "accept" "reject") (with-ht-collect (tr nil) transitions tr))) st) (defmethod print-object ((tr transition) s) (with-slots (minc maxc to) tr (format s "~@<~A~:[~*~;-~A~] -> ~A~:>" (escaped-char minc) (/= minc maxc) (escaped-char maxc) (num to)) tr)) (defun transition< (tr1 tr2) "Returns true if TR1 is strictly less than TR2. If *TO-FIRST* special variable is bound to true, the values of the destination states' NUM slots are compared first, followed by the intervals comparison. The intervals comparison is done as follows: the lower interval bounds are compared first, followed by reversed upper interval bounds comparisons. If *TO-FIRST* is bound to nil, the interval comparison is done first, followed by the NUM comparisons." (with-slots ((minc1 minc) (maxc1 maxc) (to1 to)) tr1 (with-slots ((minc2 minc) (maxc2 maxc) (to2 to)) tr2 (let ((to< (< (num to1) (num to2))) (to= (= (num to1) (num to2))) (min-rmax< (or (< minc1 minc2) (and (= minc1 minc2) (> maxc1 maxc2)))) (min-rmax= (and (= minc1 minc2) (= maxc1 maxc2)))) (if *to-first* (or to< (and to= min-rmax<)) (or min-rmax< (and min-rmax= to<))))))) (defun reset-transitions (s) (setf (transitions s) (make-generalized-hash-table +equalp-key-situation+))) (defun sstep (s c) "Returns a state reachable from S, given the input character code C." (with-ht (tr nil) (transitions s) (when (<= (minc tr) (char-code c) (maxc tr)) (return-from sstep (to tr))))) (defun add-epsilon (s to) "Adds transitions of state TO to state S. Also, if TO accepts, so does S." (when (accept to) (setf (accept s) t)) (let ((s-table (transitions s))) (with-ht (tr nil) (transitions to) (htadd s-table tr)))) (defun sorted-transition-vector (s *to-first*) "Returns a vector of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (let ((v (make-array `(,(cnt (transitions s))) :element-type '(or null transition))) (i -1)) (sort (progn (with-ht (tr nil) (transitions s) (setf (aref v (incf i)) tr)) v) #'transition<))) (defun sorted-transition-list (s *to-first*) "Returns a list of all transitions of S, sorted using TRANSITION< and *TO-FIRST*." (sort (with-ht-collect (tr nil) (transitions s) tr) #'transition<))--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/state-and-transition-test.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; (in-package :automaton-user) (deftest clone.transition.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (automaton::clone t1))) (and (eqv t1 t2 +equalp-key-situation+) (eql (hash t1 +equalp-key-situation+) (hash t2 +equalp-key-situation+)))) t) (deftest transition<.test-1 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (automaton::transition< t1 t2)) t) (deftest transition<.test-2 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\c) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (setf (automaton::num (automaton::to t1)) 1) (automaton::transition< t2 t1)) t) (deftest transition<.test-2a (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\d) :to (make-instance 'automaton::state))) (automaton::*to-first* t)) (automaton::transition< t2 t1)) t) (deftest transition<.test-3 (let ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (automaton::*to-first* nil)) (automaton::transition< t1 t2)) t) (deftest sstep.test-1 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (eq (automaton::sstep s #\a) s)) t) (deftest sstep.test-2 (let* ((s (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s))) (htadd (automaton::transitions s) tr) (automaton::sstep s #\c)) nil) (deftest add-epsilon.test-1 (let* ((s1 (make-instance 'automaton::state)) (s2 (make-instance 'automaton::state)) (tr (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to s2))) (htadd (automaton::transitions s2) tr) (automaton::add-epsilon s1 s2) (htpresent (automaton::transitions s1) tr)) t) (deftest sorted-transition-vector.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (equalp (automaton::sorted-transition-vector s nil) (vector t1 t2))) t) (deftest sorted-transition-list.test-1 (let* ((t1 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\c) :to (make-instance 'automaton::state))) (t2 (make-instance 'automaton::transition :minc (char-code #\a) :maxc (char-code #\b) :to (make-instance 'automaton::state))) (s (make-instance 'automaton::state))) (htadd (automaton::transitions s) t1) (htadd (automaton::transitions s) t2) (equal (automaton::sorted-transition-list s nil) (list t1 t2))) t)--- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; ;;; Derived from dk.brics.automaton v1.8.1, (c) 2001-2005 by Anders M??ller ;;; - Some comments have been copied verbatim from the original code. ;;; Regular expressions are built from the following abstract syntax: ;;; regexp ::= unionexp ;;; unionexp ::= interexp | unionexp (union) ;;; | interexp ;;; interexp ::= concatexp & interexp (intersection) [OPTIONAL] ;;; | concatexp ;;; concatexp ::= repeatexp concatexp (concatenation) ;;; | repeatexp ;;; repeatexp ::= repeatexp ? (zero or one occurrence) ;;; | repeatexp * (zero or more occurrences) ;;; | repeatexp + (one or more occurrences) ;;; | repeatexp {n} (n occurrences) ;;; | repeatexp {n,} (n or more occurrences) ;;; | repeatexp {n,m} (n to m occurrences, including both) ;;; | complexp ;;; complexp ::= ~ complexp (complement) [OPTIONAL] ;;; | charclassexp ;;; charclassexp ::= [ charclasses ] (character class) ;;; | [^ charclasses ] (negated character class) ;;; | simpleexp ;;; charclasses ::= charclass charclasses ;;; | charclass ;;; charclass ::= charexp - charexp (character range, including end-points) ;;; | charexp ;;; simpleexp ::= charexp ;;; | . (any single character) ;;; | # (the empty language) [OPTIONAL] ;;; | @ (any string) [OPTIONAL] ;;; | " " (a string) ;;; | ( ) (the empty string) ;;; | ( unionexp ) (precedence override) ;;; | < > (named automaton) [OPTIONAL] ;;; | (numerical interval) [OPTIONAL] ;;; charexp ::= (a single non-reserved character) ;;; | \ (a single character) ;;; The productions marked [OPTIONAL] are only allowed if specified by ;;; the syntax flags passed to the string-regexp constructor. The ;;; reserved characters used in the (enabled) syntax must be escaped ;;; with backslash (\) or double-quotes ("..."). (In contrast to other ;;; regexp syntaxes, this is required also in character classes.) Be ;;; aware that dash (-) has a special meaning in charclass ;;; expressions. An identifier is a string not containing right angle ;;; bracket (>) or dash (-). Numerical intervals are specified by ;;; non-negative decimal integers and include both end points, and if ;;; n and m have the same number of digits, then the conforming ;;; strings must have that length (i.e. prefixed by 0's). (in-package :automaton) (deftype kind () '(member nil :union :concatenation :intersection :optional :repeat :repeat-min :repeat-minmax :complement :char :char-range :anychar :empty :string :anystring :automaton :interval)) (defconstant +intersection+ #x0001) ; enables intersection (&) (defconstant +complement+ #x0002) ; enables complement (~) (defconstant +empty+ #x0004) ; enables empty language (#) (defconstant +anystring+ #x0008) ; enables anystring (@) (defconstant +automaton+ #x0010) ; enables named automaton () (defconstant +interval+ #x0020) ; enables numerical intervals (n-m) (defconstant +all+ #xffff) ; enables all optional syntax (defconstant +none+ #x0000) ; enables no optional syntax (deftype flags-type () `(integer ,+none+ ,+all+)) (defclass regexp () ((kind :initform nil :initarg :kind :reader kind :type kind) (exp1 :initform nil :initarg :exp1 :reader exp1 :type (or null regexp)) (exp2 :initform nil :initarg :exp2 :reader exp2 :type (or null regexp)) (text :initform nil :initarg :text :reader text :type (or null string)) (s :initform nil :initarg :s :reader s :type (or null string)) [342 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/regexp-test.lisp 2006/11/08 01:15:32 1.1 [592 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.txt 2006/11/08 01:15:32 1.1 [790 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash.lisp 2006/11/08 01:15:32 1.1 [911 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/eqv-hash-test.lisp 2006/11/08 01:15:32 1.1 [1087 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.lisp 2006/11/08 01:15:32 1.1 [2300 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton.asd 2006/11/08 01:15:32 1.1 [2315 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.lisp 2006/11/08 01:15:32 1.1 [2642 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test.asd 2006/11/08 01:15:32 1.1 [2657 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-test-package.lisp 2006/11/08 01:15:32 1.1 [2666 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/cl-automaton/automaton-package.lisp 2006/11/08 01:15:32 1.1 [2708 lines skipped] From thenriksen at common-lisp.net Wed Nov 8 01:15:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:15:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei/Persistent Message-ID: <20061108011532.01D7E671A3@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei/Persistent In directory clnet:/tmp/cvs-serv24994/Drei/Persistent Added Files: persistent-undo.lisp persistent-buffer.lisp obinseq.lisp binseq2.lisp binseq.lisp binseq-package.lisp README Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-undo.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Part of the Undo protocol that works with persistent buffers (in-package :drei-undo) (defclass p-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))) (defclass p-undo-record (climacs-undo-record) ((contents :initarg :contents))) (defun save-p-undo-record (buffer) (unless (performing-undo buffer) (push (make-instance 'p-undo-record :buffer buffer :contents (slot-value buffer 'drei-buffer::contents)) (undo-accumulate buffer)))) (defmethod insert-buffer-object :before ((buffer p-undo-mixin) offset object) (declare (ignore offset object)) (save-p-undo-record buffer)) (defmethod insert-buffer-sequence :before ((buffer p-undo-mixin) offset seq) (declare (ignore offset seq)) (save-p-undo-record buffer)) (defmethod delete-buffer-range :before ((buffer p-undo-mixin) offset n) (declare (ignore offset n)) (save-p-undo-record buffer)) (defmethod (setf buffer-object) :before (object (buffer p-undo-mixin) offset) (declare (ignore object offset)) (save-p-undo-record buffer)) (defmethod flip-undo-record ((record p-undo-record)) (with-slots (buffer contents) record (setf (slot-value buffer 'drei-buffer::contents) contents) (drei-buffer::filter-and-update (drei-buffer::cursors buffer) #'(lambda (c) (flexichain::weak-pointer-value c buffer)) #'(lambda (wpc) (setf (cursor-pos wpc) (max 0 (min (cursor-pos wpc) (1- (size buffer)))))))))--- /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/persistent-buffer.lisp 2006/11/08 01:15:32 1.1 ;;; -*- mode: lisp -*- ;;; ;;; (c) copyright 2005 by Aleksandar Bakic (a_bakic at yahoo.com) ;;; ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; A persistent buffer uses a persistent data structure for its ;;; contents, provides cursors into contents, and contains cursors ;;; into the current contents. (in-package :drei-buffer) ;;; For now, pos contains just an integer, while it might contain a cons ;;; of two adjacent buffer elements for higher performance (with the help ;;; of buffer implementation, especially the rebalancing part). (defclass persistent-cursor () ((buffer :reader buffer :initarg :buffer) ; TODO: fix overlap with mark? (pos :accessor cursor-pos)) (:documentation "The (non-persistent) cursor into PERSISTENT-BUFFER.")) (defclass left-sticky-persistent-cursor (persistent-cursor) ()) (defclass right-sticky-persistent-cursor (persistent-cursor) ()) (defclass line-cursor-mixin () () (:documentation "Support for line-oriented buffers.")) (defclass left-sticky-line-persistent-cursor (left-sticky-persistent-cursor line-cursor-mixin) ()) (defclass right-sticky-line-persistent-cursor (right-sticky-persistent-cursor line-cursor-mixin) ()) (defmethod cursor-pos ((cursor left-sticky-persistent-cursor)) (1+ (slot-value cursor 'pos))) (defmethod (setf cursor-pos) (position (cursor left-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) (1- position))) (defmethod cursor-pos ((cursor right-sticky-persistent-cursor)) (slot-value cursor 'pos)) (defmethod (setf cursor-pos) (position (cursor right-sticky-persistent-cursor)) (assert (<= 0 position (size (buffer cursor))) () "Cursor position out of bounds: ~S, ~S" cursor position) (setf (slot-value cursor 'pos) position)) (defclass persistent-buffer (buffer) ((low-mark :reader low-mark) (high-mark :reader high-mark) (cursors :accessor cursors :initform nil) (modified :initform nil :reader modified-p)) (:documentation "The Climacs persistent buffer base class \(non-instantiable).")) (defmethod initialize-instance :after ((cursor left-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos (1- position)) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defmethod initialize-instance :after ((cursor right-sticky-persistent-cursor) &rest initargs &key (position 0)) (declare (ignorable initargs)) (with-slots (buffer pos) cursor (setf pos position) (with-slots (cursors) buffer (push (flexichain::make-weak-pointer cursor) cursors)))) (defclass binseq-buffer (persistent-buffer) ((contents :initform (list-binseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for the CONTENTS slot.")) (defclass obinseq-buffer (persistent-buffer) ((contents :initform (list-obinseq nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses an optimized binary sequence (only non-nil atoms are allowed as elements) for the CONTENTS slot.")) (defclass binseq2-buffer (persistent-buffer) ((contents :initform (list-binseq2 nil))) (:documentation "An instantiable subclass of PERSISTENT-BUFFER that uses a binary sequence for lines and optimized binary sequences for line contents, all kept in the CONTENTS slot.")) (defclass p-mark-mixin () ((buffer :initarg :buffer :reader buffer) (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark that is used in a PERSISTENT-BUFFER.")) (defclass p-line-mark-mixin (p-mark-mixin) () (:documentation "A persistent mark mixin class that works with cursors that can efficiently work with lines.")) (defmethod backward-object ((mark p-mark-mixin) &optional (count 1)) (decf (offset mark) count)) (defmethod forward-object ((mark p-mark-mixin) &optional (count 1)) (incf (offset mark) count)) (defmethod offset ((mark p-mark-mixin)) (cursor-pos (cursor mark))) (defmethod (setf offset) (new-offset (mark p-mark-mixin)) (assert (<= 0 new-offset) () (make-condition 'motion-before-beginning :offset new-offset)) (assert (<= new-offset (size (buffer mark))) () (make-condition 'motion-after-end :offset new-offset)) (setf (cursor-pos (cursor mark)) new-offset)) (defclass persistent-left-sticky-mark (left-sticky-mark p-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-mark (right-sticky-mark p-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-left-sticky-line-mark (left-sticky-mark p-line-mark-mixin) () (:documentation "A LEFT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defclass persistent-right-sticky-line-mark (right-sticky-mark p-line-mark-mixin) () (:documentation "A RIGHT-STICKY-MARK subclass with line support, suitable for use in a PERSISTENT-BUFFER.")) (defmethod initialize-instance :after ((mark persistent-left-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-left-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'left-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((mark persistent-right-sticky-line-mark) &rest args &key (offset 0)) "Associates a created mark with the buffer for which it was created." (declare (ignorable args)) (assert (<= 0 offset) () (make-condition 'motion-before-beginning :offset offset)) (assert (<= offset (size (buffer mark))) () (make-condition 'motion-after-end :offset offset)) (setf (slot-value mark 'cursor) (make-instance 'right-sticky-line-persistent-cursor :buffer (buffer mark) :position offset))) (defmethod initialize-instance :after ((buffer binseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) (defmethod initialize-instance :after ((buffer obinseq-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-mark :buffer buffer)))) (defmethod initialize-instance :after ((buffer binseq2-buffer) &rest args) "Create the low-mark and high-mark." (declare (ignorable args)) (with-slots (low-mark high-mark) buffer (setf low-mark (make-instance 'persistent-left-sticky-line-mark :buffer buffer)) (setf high-mark (make-instance 'persistent-right-sticky-line-mark :buffer buffer)))) (defmethod clone-mark ((mark persistent-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-left-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :right) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod clone-mark ((mark persistent-right-sticky-line-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :right)) (make-instance 'persistent-right-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) ((eq stick-to :left) (make-instance 'persistent-left-sticky-line-mark :buffer (buffer mark) :offset (offset mark))) (t (error "invalid value for stick-to")))) (defmethod size ((buffer binseq-buffer)) (binseq-length (slot-value buffer 'contents))) (defmethod size ((buffer obinseq-buffer)) (obinseq-length (slot-value buffer 'contents))) (defmethod size ((buffer binseq2-buffer)) (binseq2-size (slot-value buffer 'contents))) (defmethod number-of-lines ((buffer persistent-buffer)) (loop for offset from 0 below (size buffer) count (eql (buffer-object buffer offset) #\Newline))) (defmethod number-of-lines ((buffer binseq2-buffer)) (let ((len (binseq2-length (slot-value buffer 'contents))) (size (size buffer))) (if (or (eql 0 size) (eq (buffer-object buffer (1- size)) #\Newline)) len (max 0 (1- len))))) ; weird? (defmethod mark< ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (< (offset mark1) (offset mark2))) (defmethod mark< ((mark1 p-mark-mixin) (mark2 integer)) (< (offset mark1) mark2)) (defmethod mark< ((mark1 integer) (mark2 p-mark-mixin)) (< mark1 (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (<= (offset mark1) (offset mark2))) (defmethod mark<= ((mark1 p-mark-mixin) (mark2 integer)) (<= (offset mark1) mark2)) (defmethod mark<= ((mark1 integer) (mark2 p-mark-mixin)) (<= mark1 (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (= (offset mark1) (offset mark2))) (defmethod mark= ((mark1 p-mark-mixin) (mark2 integer)) (= (offset mark1) mark2)) (defmethod mark= ((mark1 integer) (mark2 p-mark-mixin)) (= mark1 (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (> (offset mark1) (offset mark2))) (defmethod mark> ((mark1 p-mark-mixin) (mark2 integer)) (> (offset mark1) mark2)) (defmethod mark> ((mark1 integer) (mark2 p-mark-mixin)) (> mark1 (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 p-mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) (>= (offset mark1) (offset mark2))) (defmethod mark>= ((mark1 p-mark-mixin) (mark2 integer)) (>= (offset mark1) mark2)) (defmethod mark>= ((mark1 integer) (mark2 p-mark-mixin)) (>= mark1 (offset mark2))) [398 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/obinseq.lisp 2006/11/08 01:15:32 1.1 [631 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq2.lisp 2006/11/08 01:15:32 1.1 [1007 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq.lisp 2006/11/08 01:15:32 1.1 [1233 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/binseq-package.lisp 2006/11/08 01:15:32 1.1 [1327 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/Persistent/README 2006/11/08 01:15:32 1.1 [1337 lines skipped] From thenriksen at common-lisp.net Wed Nov 8 01:15:33 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:15:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061108011533.B2BB369002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv24994/Drei Added Files: unicode-commands.lisp undo.lisp syntax.lisp search-commands.lisp rectangle.lisp packages.lisp motion.lisp motion-commands.lisp misc-commands.lisp lisp-syntax.lisp lisp-syntax-swine.lisp lisp-syntax-swank.lisp lisp-syntax-commands.lisp kill-ring.lisp kill-ring-test.lisp input-editor.lisp fundamental-syntax.lisp editing.lisp editing-commands.lisp drei.lisp drei.asd drei-redisplay.lisp drei-clim.lisp delegating-buffer.lisp core.lisp core-commands.lisp buffer.lisp buffer-test.lisp basic-commands.lisp base.lisp base-test.lisp abbrev.lisp Log Message: Committed Drei. --- /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/unicode-commands.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-COMMANDS -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2004-2005 by ;;; Elliott Johnson (ejohnson at fasl.info) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; (c) copyright 2005 by ;;; Aleksandar Bakic (a_bakic at yahoo.com) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; Unicode handling for the editing component of the Climacs editor. (in-package :drei-commands) (do ((i 160 (+ i 1))) ((> i 255)) (set-key `(com-self-insert ,*numeric-argument-marker*) 'self-insert-table (list (code-char i)))) (define-command (com-insert-charcode :name t :command-table self-insert-table) ((code 'integer :prompt "Code point") (count 'integer)) (let ((char (code-char code))) (loop repeat count do (insert-character char)))) (macrolet ((set-charcode-key (code sequence) `(set-key `(com-insert-charcode ,',code ,*numeric-argument-marker*) 'self-insert-table ',sequence)) (set-dead-acute-key (code &rest sequence) `(set-charcode-key ,code ((:dead-acute) , at sequence))) (set-dead-grave-key (code &rest sequence) `(set-charcode-key ,code ((:dead-grave) , at sequence))) (set-dead-diaresis-key (code &rest sequence) `(set-charcode-key ,code ((:dead-diaresis :shift) , at sequence))) (set-dead-tilde-key (code &rest sequence) `(set-charcode-key ,code ((:dead-tilde :shift) , at sequence))) (set-dead-circumflex-key (code &rest sequence) `(set-charcode-key ,code ((:dead-circumflex :shift) , at sequence)))) (set-dead-acute-key 193 (#\A)) (set-dead-acute-key 201 (#\E)) (set-dead-acute-key 205 (#\I)) (set-dead-acute-key 211 (#\O)) (set-dead-acute-key 218 (#\U)) (set-dead-acute-key 221 (#\Y)) (set-dead-acute-key 225 (#\a)) (set-dead-acute-key 233 (#\e)) (set-dead-acute-key 237 (#\i)) (set-dead-acute-key 243 (#\o)) (set-dead-acute-key 250 (#\u)) (set-dead-acute-key 253 (#\y)) (set-dead-acute-key 199 (#\C)) (set-dead-acute-key 231 (#\c)) (set-dead-acute-key 215 (#\x)) (set-dead-acute-key 247 (#\-)) (set-dead-acute-key 222 (#\T)) (set-dead-acute-key 254 (#\t)) (set-dead-acute-key 223 (#\s)) (set-dead-acute-key 39 (#\Space)) (set-dead-acute-key 197 (:dead-acute) (#\A)) (set-dead-acute-key 229 (:dead-acute) (#\a)) (set-dead-grave-key 192 (#\A)) (set-dead-grave-key 200 (#\E)) (set-dead-grave-key 204 (#\I)) (set-dead-grave-key 210 (#\O)) (set-dead-grave-key 217 (#\U)) (set-dead-grave-key 224 (#\a)) (set-dead-grave-key 232 (#\e)) (set-dead-grave-key 236 (#\i)) (set-dead-grave-key 242 (#\o)) (set-dead-grave-key 249 (#\u)) (set-dead-grave-key 96 (#\Space)) (set-dead-diaresis-key 196 (#\A)) (set-dead-diaresis-key 203 (#\E)) (set-dead-diaresis-key 207 (#\I)) (set-dead-diaresis-key 214 (#\O)) (set-dead-diaresis-key 220 (#\U)) (set-dead-diaresis-key 228 (#\a)) (set-dead-diaresis-key 235 (#\e)) (set-dead-diaresis-key 239 (#\i)) (set-dead-diaresis-key 246 (#\o)) (set-dead-diaresis-key 252 (#\u)) (set-dead-diaresis-key 255 (#\y)) (set-dead-diaresis-key 34 (#\Space)) (set-dead-tilde-key 195 (#\A)) (set-dead-tilde-key 209 (#\N)) (set-dead-tilde-key 227 (#\a)) (set-dead-tilde-key 241 (#\n)) (set-dead-tilde-key 198 (#\E)) (set-dead-tilde-key 230 (#\e)) (set-dead-tilde-key 208 (#\D)) (set-dead-tilde-key 240 (#\d)) (set-dead-tilde-key 248 (#\o)) (set-dead-tilde-key 126 (#\Space)) (set-dead-circumflex-key 194 (#\A)) (set-dead-circumflex-key 202 (#\E)) (set-dead-circumflex-key 206 (#\I)) (set-dead-circumflex-key 212 (#\O)) (set-dead-circumflex-key 219 (#\U)) (set-dead-circumflex-key 226 (#\a)) (set-dead-circumflex-key 234 (#\e)) (set-dead-circumflex-key 238 (#\i)) (set-dead-circumflex-key 244 (#\o)) (set-dead-circumflex-key 251 (#\u)) (set-dead-circumflex-key 94 (#\Space))) --- /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/undo.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-UNDO -*- ;;; (c) copyright 2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. ;;; General-purpose undo module (in-package :drei-undo) (defgeneric add-undo (undo-record undo-tree) (:documentation "Add an undo record to the undo tree below the current state, and set the current state to be below the transition represented by the undo record.")) (defgeneric flip-undo-record (undo-record) (:documentation "This function is called by the undo module whenever the current state is changed from its current value to that of the parent state (presumably as a result of a call to undo) or to that of one of its child states. Client code is required to supply methods for this function on 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). 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).")) (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.")) (defclass undo-tree () () (:documentation "Protocol class for all undo trees")) (defclass standard-undo-tree (undo-tree) ((current-record :accessor current-record) (leaf-record :accessor leaf-record) (redo-path :initform '() :accessor redo-path) (children :initform '() :accessor children) (depth :initform 0 :reader depth)) (:documentation "Standard instantiable class for undo trees.")) (defmethod initialize-instance :after ((tree standard-undo-tree) &rest args) (declare (ignore args)) (setf (current-record tree) tree (leaf-record tree) tree)) (defclass undo-record () () (:documentation "The protocol class for all undo records.")) (defclass standard-undo-record (undo-record) ((parent :initform nil :accessor parent) (tree :initform nil :accessor undo-tree) (children :initform '() :accessor children) (depth :initform nil :accessor depth)) (:documentation "Standard instantiable class for undo records.")) (defmethod add-undo ((record standard-undo-record) (tree standard-undo-tree)) (push record (children (current-record tree))) (setf (undo-tree record) tree (parent record) (current-record tree) (depth record) (1+ (depth (current-record tree))) (current-record tree) record (leaf-record tree) record (redo-path tree) '())) (defmethod undo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (depth (current-record tree))) () (make-condition 'no-more-undo)) (loop repeat n do (flip-undo-record (current-record tree)) (push (current-record tree) (redo-path tree)) (setf (current-record tree) (parent (current-record tree))))) (defmethod redo ((tree standard-undo-tree) &optional (n 1)) (assert (<= n (- (depth (leaf-record tree)) (depth (current-record tree)))) () (make-condition 'no-more-undo)) (loop repeat n do (setf (current-record tree) (pop (redo-path tree))) (flip-undo-record (current-record tree)))) --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/08 01:15:33 1.1 ;;; -*- Mode: Lisp; Package: DREI-SYNTAX -*- ;;; (c) copyright 2004-2005 by ;;; Robert Strandh (strandh at labri.fr) ;;; (c) copyright 2005 by ;;; Matthieu Villeneuve (matthieu.villeneuve at free.fr) ;;; This library is free software; you can redistribute it and/or ;;; modify it under the terms of the GNU Library General Public ;;; License as published by the Free Software Foundation; either ;;; version 2 of the License, or (at your option) any later version. ;;; ;;; This library is distributed in the hope that it will be useful, ;;; but WITHOUT ANY WARRANTY; without even the implied warranty of ;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the GNU ;;; Library General Public License for more details. ;;; ;;; You should have received a copy of the GNU Library General Public ;;; License along with this library; if not, write to the ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. (in-package :drei-syntax) (defclass syntax (name-mixin) ((buffer :initarg :buffer :reader buffer) (command-table :initarg :command-table :initform nil :reader command-table) (%cursor-positions :accessor cursor-positions :initform nil))) (defun syntaxp (object) "Return T if `object' is an instance of a syntax, NIL otherwise." (typep object 'syntax)) (define-condition no-such-operation (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "Operation unavailable for this syntax"))) (:documentation "This condition is signaled whenever an attempt is made to execute an operation that is unavailable for the particular syntax" )) (define-condition no-expression (simple-error) () (:report (lambda (condition stream) (declare (ignore condition)) (format stream "No expression at point"))) (: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 syntax-line-indentation (mark tab-width syntax) (:documentation "Return the correct indentation for the line containing the mark, according to the specified syntax.")) (defgeneric eval-defun (mark syntax)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Syntax command tables. (defclass syntax-command-table (standard-command-table) () (:documentation "A syntax command table provides facilities for having frame-specific commands that do not show up when the syntax is used in other applications than the one it is supposed to. For example, the Return From Definition command should be available when Lisp syntax is used in Climacs (or another editor), but not anywhere else.")) (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Get a list of additional command tables that should be checked for commands in addition to those `command-table' inherits from. The idea is that methods are specialised to `editor', and that those methods may call the function again recursively with a new `editor' argument to provide arbitrary granularity for command-table-selection. For instance, some commands may be applicable in a situation where the editor is a pane or gadget in its own right, but not when it functions as an input-editor. In this case, a method could be defined for `application-frame' as the `editor' argument, that calls `additional-command-tables' again with whatever the \"current\" editor instance is.") (:method append (editor command-table) '())) (defmethod command-table-inherit-from ((table syntax-command-table)) "Fetch extra command tables to inherit from (using `additional-command-tables') as well as the command tables `table' actually directly inherits from." (append (additional-command-tables *application-frame* table) (call-next-method))) (defmacro define-syntax-command-table (name &rest args &key &allow-other-keys) "Define a syntax command table class with the provided name, as well as defining a CLIM command table of the same name. `Args' will be passed on to `make-command-table'. An :around method on `command-table-inherit-from' for the defined class will also be defined. This method will make sure that when an instance of the syntax command table is asked for its inherited command tables, it will return those of the defined CLIM command table, as well as those provided by methods on `additional-command-tables'. Command tables provided through `additional-command-tables' will take precence over those specified in the usual way with :inherit-from." `(progn (make-command-table ',name , at args) (defclass ,name (syntax-command-table) ()) (defmethod command-table-inherit-from :around ((table ,name)) (append (call-next-method) '(,name) (command-table-inherit-from (find-command-table ',name)))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Commenting (defgeneric syntax-line-comment-string (syntax) (:documentation "string to use at the beginning of a line to indicate a line comment")) (defgeneric line-comment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-comment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))) (loop while (mark< mark mark2) do (insert-sequence mark (syntax-line-comment-string syntax)) (end-of-line mark) (unless (end-of-buffer-p mark) (forward-object mark))))) (defgeneric line-uncomment-region (syntax mark1 mark2) (:documentation "inset a line comment string at the beginning of every line in the region")) (defmethod line-uncomment-region (syntax mark1 mark2) (when (mark< mark2 mark1) (rotatef mark1 mark2)) (let ((mark (clone-mark mark1))) (unless (beginning-of-line-p mark) (end-of-line mark) (unless (end-of-buffer-p mark) [666 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2006/11/08 01:15:33 1.1 [1120 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/rectangle.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/rectangle.lisp 2006/11/08 01:15:33 1.1 [1257 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/08 01:15:33 1.1 [1681 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/08 01:15:33 1.1 [2188 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/motion-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/motion-commands.lisp 2006/11/08 01:15:33 1.1 [2210 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/misc-commands.lisp 2006/11/08 01:15:33 1.1 [2295 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 1.1 [5304 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 1.1 [6407 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swank.lisp 2006/11/08 01:15:33 1.1 [6513 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 1.1 [6803 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/08 01:15:33 1.1 [6978 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring-test.lisp 2006/11/08 01:15:33 1.1 [7096 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 1.1 [7680 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 1.1 [8031 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 1.1 [8297 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/editing-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/editing-commands.lisp 2006/11/08 01:15:33 1.1 [8331 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/08 01:15:33 1.1 [9041 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei.asd 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei.asd 2006/11/08 01:15:33 1.1 [9088 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 1.1 [9519 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 1.1 [10008 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/delegating-buffer.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/delegating-buffer.lisp 2006/11/08 01:15:33 1.1 [10080 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/core.lisp 2006/11/08 01:15:33 1.1 [10498 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/08 01:15:33 1.1 [11224 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 1.1 [11886 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/buffer-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/buffer-test.lisp 2006/11/08 01:15:33 1.1 [12948 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 1.1 [13455 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/08 01:15:33 1.1 [14262 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/base-test.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/base-test.lisp 2006/11/08 01:15:33 1.1 [15544 lines skipped] --- /project/mcclim/cvsroot/mcclim/Drei/abbrev.lisp 2006/11/08 01:15:33 NONE +++ /project/mcclim/cvsroot/mcclim/Drei/abbrev.lisp 2006/11/08 01:15:33 1.1 [15635 lines skipped] From thenriksen at common-lisp.net Wed Nov 8 01:19:02 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:19:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061108011902.34434210B6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25509 Modified Files: mcclim.asd Log Message: Commit mcclim.asd changes to load Drei and the other added files. May contain trace amounts of ugly (and necessary complexity). --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/05 19:00:54 1.32 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/08 01:19:02 1.33 @@ -32,6 +32,16 @@ (defparameter *clim-directory* (directory-namestring *load-truename*)) +(eval-when (:compile-toplevel :load-toplevel :execute) + (defun find-swank-package () + (find-package :swank)) + (defun find-swank-system () + (handler-case (asdf:find-system :swank) + (asdf:missing-component ()))) + (defun find-swank () + (or (find-swank-package) + (find-swank-system)))) + ;;; Legacy CMUCL support stuff #+cmu (progn @@ -93,7 +103,7 @@ #+clisp "fix-clisp"))) (:file "package" :depends-on ("Lisp-Dep" "patch")))) -(defsystem :clim-core +(defsystem :clim-basic :depends-on (:clim-lisp :spatial-trees) :components ((:file "decls") (:file "protocol-classes" :depends-on ("decls")) @@ -145,7 +155,7 @@ "events")))) (defsystem :goatee-core - :depends-on (:clim-core) + :depends-on (:clim-basic) :components ((:module "Goatee" :components @@ -169,67 +179,140 @@ (:file "presentation-history" :depends-on ("editing-stream" "buffer" "flexivector" "editable-buffer" "goatee-command")))))) - ;;; CLIM-PostScript is not a backend in the normal sense. ;;; It is an extension (Chap. 35.1 of the spec) and is an ;;; "included" part of McCLIM. Hence the defsystem is here. (defsystem :clim-postscript - :depends-on (:clim-core) - :components - ((:module "Backends/PostScript" - :pathname #.(make-pathname :directory '(:relative "Backends" "PostScript")) - :components - ((:file "package") - (:file "encoding" :depends-on ("package")) - (:file "paper" :depends-on ("package")) - (:file "class" :depends-on ("paper" "package")) - (:file "font" :depends-on ("encoding" "class" "paper" "package")) - (:file "graphics" :depends-on ("encoding" "paper" "class" "font" "package")) - (:file "sheet" :depends-on ("paper" "class" "graphics" "package")) - (:file "afm" :depends-on ("class" "paper" "font" "package")) - (:file "standard-metrics" :depends-on ("font" "package")))))) + :depends-on (:clim-basic) + :components + ((:module "Backends/PostScript" + :pathname #.(make-pathname :directory '(:relative "Backends" "PostScript")) + :components + ((:file "package") + (:file "encoding" :depends-on ("package")) + (:file "paper" :depends-on ("package")) + (:file "class" :depends-on ("paper" "package")) + (:file "font" :depends-on ("encoding" "class" "paper" "package")) + (:file "graphics" :depends-on ("encoding" "paper" "class" "font" "package")) + (:file "sheet" :depends-on ("paper" "class" "graphics" "package")) + (:file "afm" :depends-on ("class" "paper" "font" "package")) + (:file "standard-metrics" :depends-on ("font" "package")))))) + +(defsystem :clim-core + :depends-on (:clim-basic :goatee-core :clim-postscript) + :components ((:file "text-formatting") + (:file "defresource") + (:file "input-editing") + (:file "presentations") + (:file "pointer-tracking" :depends-on ("input-editing")) + (:file "graph-formatting") + (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" + "pointer-tracking" "incremental-redisplay")) + (:file "table-formatting" :depends-on ("presentation-defs" "panes" + "presentations" "input-editing")) + (:file "bordered-output" :depends-on ("input-editing" "incremental-redisplay" + "presentation-defs" "panes")) + (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" + "bordered-output" "presentation-defs")) + (:file "presentation-defs" :depends-on ("input-editing" "presentations")) + (:file "gadgets" :depends-on ("commands" "pointer-tracking" "input-editing" + "frames" "incremental-redisplay" "panes")) + (:file "describe" :depends-on ("presentations" "presentation-defs" "table-formatting")) + (:file "commands" :depends-on ("input-editing" "presentations" + "presentation-defs")) + (:file "incremental-redisplay" :depends-on ("presentation-defs")) + (:file "menu-choose" :depends-on ("commands" "table-formatting" "presentation-defs" + "panes" "frames" "pointer-tracking" + "presentations")) + (:file "menu" :depends-on ("panes" "commands" "gadgets" + "presentations" "frames")) + (:file "panes" :depends-on ("incremental-redisplay" "presentations" + "presentation-defs" "input-editing" "frames")) + (:file "dialog" :depends-on ("panes" "frames" "incremental-redisplay" + "table-formatting" "presentations" + "bordered-output" "presentation-defs" + "dialog-views" "input-editing" + "commands")) + (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" + "presentation-defs" "input-editing")))) + +(defsystem :esa-mcclim + :depends-on (:clim-core) + :components ((:module "ESA" + :components ((:file "packages") + (:file "utils" :depends-on ("packages")) + (:file "colors" :depends-on ("packages")) + (:file "esa" :depends-on ("colors" "packages" "utils")) + (:file "esa-buffer" :depends-on ("packages" "esa")) + (:file "esa-io" :depends-on ("packages" "esa" "esa-buffer")) + (:file "esa-command-parser" :depends-on ("packages" "esa")))))) + + + +(defsystem :drei-mcclim + :depends-on (:flexichain :esa-mcclim :clim-core #.(if (find-swank-system) :swank (values))) + :components + ((:module "cl-automaton" + :pathname #.(make-pathname :directory '(:relative "Drei" "cl-automaton")) + :components ((:file "automaton-package") + (:file "eqv-hash" :depends-on ("automaton-package")) + (:file "state-and-transition" :depends-on ("eqv-hash")) + (:file "automaton" :depends-on ("state-and-transition" "eqv-hash")) + (:file "regexp" :depends-on ("automaton")))) + (:module "Persistent" + :pathname #.(make-pathname :directory '(:relative "Drei" "Persistent")) + :components ((:file "binseq-package") + (:file "binseq" :depends-on ("binseq-package")) + (:file "obinseq" :depends-on ("binseq-package" "binseq")) + (:file "binseq2" :depends-on ("binseq-package" "obinseq" "binseq")))) + (:module "Drei" :depends-on ("cl-automaton" "Persistent") + :components ((:file "packages") + (:file "buffer" :depends-on ("packages")) + (:file "motion" :depends-on ("packages" "buffer" "syntax")) + (:file "editing" :depends-on ("packages" "buffer" "syntax" "motion" "kill-ring")) + (:file "base" :depends-on ("packages" "buffer" "persistent-buffer" "kill-ring")) + (:file "syntax" :depends-on ("packages" "buffer" "base")) + (:file "drei" :depends-on ("packages" "syntax" "buffer" "base" + "persistent-undo" "persistent-buffer" "abbrev" + "delegating-buffer" "undo" "motion" "editing")) + (:file "drei-clim" :depends-on ("drei")) + (:file "drei-redisplay" :depends-on ("drei-clim")) + (:file "input-editor" :depends-on ("drei-redisplay" "lisp-syntax")) + (:file "fundamental-syntax" :depends-on ("packages" "drei-redisplay")) + (:file "abbrev" :depends-on ("packages")) + (:file "kill-ring" :depends-on ("packages")) + (:file "undo" :depends-on ("packages")) + (:file "delegating-buffer" :depends-on ("packages" "buffer")) + (:file "basic-commands" :depends-on ("drei-clim" "motion" "editing")) + (:file "core" :depends-on ("drei")) + (:file "rectangle" :depends-on ("core")) + (:file "core-commands" :depends-on ("core" "rectangle" "drei-clim")) + (:file "persistent-buffer" + :pathname #.(make-pathname :directory '(:relative "Persistent") + :name "persistent-buffer" + :type "lisp") + :depends-on ("packages")) + (:file "persistent-undo" + :pathname #p"Persistent/persistent-undo.lisp" + :depends-on ("packages" "buffer" "persistent-buffer" "undo")) + (:file "misc-commands" :depends-on ("basic-commands")) + (:file "unicode-commands" :depends-on ("core" "drei-clim")) + (:file "search-commands" :depends-on ("core" "drei-clim")) + (:file "lisp-syntax" :depends-on ("core" "motion" "fundamental-syntax")) + (:file "lisp-syntax-swine" :depends-on ("lisp-syntax")) + (:file "lisp-syntax-commands" :depends-on ("lisp-syntax-swine" "misc-commands")) + #.(if (find-swank) + '(:file "lisp-syntax-swank" :depends-on ("lisp-syntax")) + (values)))))) (defsystem :clim - :depends-on (:clim-core :goatee-core) - :components - ((:file "text-formatting") - (:file "input-editing") - (:file "presentations") - (:file "defresource") - (:file "presentation-defs" :depends-on ("input-editing" "presentations")) - (:file "pointer-tracking" :depends-on ("input-editing")) - (:file "commands" :depends-on ("input-editing" "presentations" - "presentation-defs")) - (:file "incremental-redisplay" :depends-on ("presentation-defs")) - (:file "frames" :depends-on ("commands" "presentations" "presentation-defs" - "pointer-tracking" "incremental-redisplay")) - (:file "panes" :depends-on ("incremental-redisplay" "presentations" - "presentation-defs" "input-editing" "frames")) - (:file "gadgets" :depends-on ("commands" "pointer-tracking" "input-editing" - "frames" "incremental-redisplay" "panes")) - (:file "menu" :depends-on ("panes" "commands" "gadgets" - "presentations" "frames")) - (:file "table-formatting" :depends-on ("presentation-defs" "panes" - "presentations" "input-editing")) - (:file "graph-formatting") - (:file "bordered-output" :depends-on ("input-editing" "incremental-redisplay" - "presentation-defs" "panes")) - (:file "dialog-views" :depends-on ("presentations" "incremental-redisplay" - "bordered-output" "presentation-defs")) - (:file "dialog" :depends-on ("panes" "frames" "incremental-redisplay" - "table-formatting" "presentations" - "bordered-output" "presentation-defs" - "dialog-views" "input-editing" - "commands")) - (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" - "presentation-defs" "input-editing")) - (:file "describe" :depends-on ("presentations" "presentation-defs" "table-formatting")) - (:file "menu-choose" :depends-on ("commands" "table-formatting" "presentation-defs" - "panes" "frames" "pointer-tracking" - "presentations")) - (:file "Goatee/presentation-history" :depends-on ("presentation-defs") ; XXX: this is loaded as part of the Goatee system. huh? - :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) - )) + :depends-on (:clim-core :goatee-core :clim-postscript :drei-mcclim) + :components + ((:file "Goatee/presentation-history" ; XXX: this is loaded as part of the Goatee system. huh? + :pathname #.(make-pathname :directory '(:relative "Goatee") :name "presentation-history" :type "lisp")) + (:file "input-editing-goatee") + (:file "input-editing-drei") + (:file "text-editor-gadget"))) (defsystem :clim-clx :depends-on (:clim #+(or sbcl openmcl ecl allegro) :clx) @@ -437,3 +520,15 @@ (defmethod perform :after ((op load-op) (c (eql (find-system :mcclim)))) (pushnew :clim *features*) (pushnew :mcclim *features*)) + +;; XXX This is very ugly, but ESA and Drei need to know whether they +;; are being compiled as part of McCLIM, or in another CLIM +;; implementation. +(defmethod perform :around (op c) + (if (and (or (eql (component-system c) (find-system :esa-mcclim)) + (eql (component-system c) (find-system :drei-mcclim))) + (not (find :building-mcclim *features*))) + (unwind-protect (progn (push :building-mcclim *features*) + (call-next-method)) + (setf *features* (delete :building-mcclim *features*))) + (call-next-method))) From thenriksen at common-lisp.net Wed Nov 8 01:19:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 7 Nov 2006 20:19:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Inspector Message-ID: <20061108011949.47CE6210B6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory clnet:/tmp/cvs-serv25597/Apps/Inspector Modified Files: clouseau.asd Log Message: Make Clouseau's system definition inter-file dependencies explicit, just for good measure. --- /project/mcclim/cvsroot/mcclim/Apps/Inspector/clouseau.asd 2005/06/15 09:04:43 1.6 +++ /project/mcclim/cvsroot/mcclim/Apps/Inspector/clouseau.asd 2006/11/08 01:19:49 1.7 @@ -25,5 +25,5 @@ :serial t :components ((:file "package") - (:file "disassembly") - (:file "inspector"))) + (:file "disassembly" :depends-on ("package")) + (:file "inspector" :depends-on ("disassembly")))) From thenriksen at common-lisp.net Wed Nov 8 13:08:12 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 8 Nov 2006 08:08:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061108130812.A28AF232CA@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9855 Modified Files: input-editor.lisp drei-clim.lisp Log Message: Implemented `add-input-editor-command' as per the Franz User Guide. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 13:08:12 1.2 @@ -176,8 +176,7 @@ (with-accessors ((buffer buffer)) (drei-instance stream) (let* ((array (buffer-sequence buffer 0 (size buffer)))) (make-array (length array) - :fill-pointer t - :adjustable t + :fill-pointer (length array) :initial-contents array)))) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) @@ -252,6 +251,10 @@ printed-rep) args)))) +(defvar *drei-input-editing-stream* nil + "Used to provide CLIM-specified input-editing-commands with the +input-editing-stream. Bound when executing a command.") + ;;; Have to reexamine how many of the keyword arguments to ;;; stream-read-gesture should really be passed to the encapsulated ;;; stream. @@ -356,7 +359,8 @@ (drei (drei-instance stream)) (*command-processor* drei) (was-directly-processing (directly-processing-p drei)) - (minibuffer (or (minibuffer drei) *minibuffer*))) + (minibuffer (or (minibuffer drei) *minibuffer*)) + (*drei-input-editing-stream* stream)) (with-bound-drei-special-variables (drei ;; If the minibuffer is the ;; stream we are encapsulating @@ -500,19 +504,22 @@ ;;; CLIM spec does not define, or even suggest, any kind of ;;; programmatic access to the data structures of the input-editor for ;;; these function, it is utterly impossible to write portable -;;; input-editor functions using this -;;; facility. `Add-input-editor-command' is implemented like this in -;;; Drei: the specified gesture sequence is bound to the provided -;;; function in the `editor-table' command table, and will have a -;;; standard Drei command environment when invoked. This is sufficient -;;; for only the most trivial of commands, using `define-command' and -;;; `set-key' is a much, much more powerful mechanism, and it allows -;;; far more elegant handling of numeric arguments. +;;; input-editor functions using this facility. Fortunately, Franz's +;;; user guide saves us. An input-editor-command defined via this +;;; facility takes four arguments: the input-editing stream, the input +;;; buffer (ugh!), the gesture used to invoke the command, and the +;;; accumulated numeric argument. (defun add-input-editor-command (gestures function) "Set up Drei so performing `gestures' will result in the invocation of `function' " - (set-key function 'editor-table gestures)) + (set-key `(,(lambda (numeric-argument) + (funcall function *drei-input-editing-stream* + (stream-input-buffer *drei-input-editing-stream*) + gestures + numeric-argument)) ,*numeric-argument-marker*) + 'exclusive-input-editor-table + gestures)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 13:08:12 1.2 @@ -58,20 +58,20 @@ (make-command-table 'self-insert-table :errorp nil) ;;; Command table for concrete editor stuff. -(make-command-table 'editor-table - :errorp nil - :inherit-from '(comment-table - deletion-table - editing-table - case-table - fill-table - indent-table - marking-table - movement-table - search-table - info-table - self-insert-table - keyboard-macro-table)) +(define-syntax-command-table editor-table + :errorp nil + :inherit-from '(comment-table + deletion-table + editing-table + case-table + fill-table + indent-table + marking-table + movement-table + search-table + info-table + self-insert-table + keyboard-macro-table)) ;; Command table for commands that are only available when Drei is a ;; pane. From thenriksen at common-lisp.net Wed Nov 8 17:52:55 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 8 Nov 2006 12:52:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061108175255.62F635F01E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv15306 Modified Files: lisp-syntax.lisp fundamental-syntax.lisp drei-redisplay.lisp Log Message: Fix obscure redisplay issue that appeared when the input begins with whitespace in the input-editor. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 17:52:55 1.2 @@ -2029,7 +2029,7 @@ (loop for child in (cdr children) do (display-parse-tree child stream drei syntax)))) -(defmethod display-drei-contents (stream (drei drei) (syntax lisp-syntax)) +(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax lisp-syntax)) (with-slots (top bot) drei (with-accessors ((cursor-positions cursor-positions)) syntax ;; There must always be room for at least one element of line --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 17:52:55 1.2 @@ -109,7 +109,7 @@ pane (- tab-width (mod x tab-width)) 0)))) (incf start)))))) -(defmethod display-line (stream (drei drei) mark) +(defmethod display-line ((stream clim-stream-pane) (drei drei) mark) (let ((mark (clone-mark mark))) (with-accessors ((space-width space-width) (tab-width tab-width)) stream (let ((saved-offset nil) @@ -120,7 +120,7 @@ saved-offset mark) 'string))) - (updating-output (stream :unique-id (cons stream (incf id)) + (updating-output (stream :unique-id (cons drei (incf id)) :id-test #'equal :cache-value contents :cache-test #'equal) @@ -162,7 +162,7 @@ (unless (end-of-buffer-p mark) (terpri stream))))))))) -(defmethod display-drei-contents (stream drei (syntax fundamental-syntax)) +(defmethod display-drei-contents ((stream clim-stream-pane) (drei drei) (syntax fundamental-syntax)) (with-slots (top bot) drei (with-accessors ((cursor-positions cursor-positions)) syntax (setf cursor-positions (make-array (1+ (number-of-lines-in-region top bot)) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 17:52:55 1.2 @@ -53,6 +53,16 @@ (letf (((stream-default-view stream) (view drei))) (call-next-method)))) +;; XXX: If the display begins with a blank area - for example spaces - +;; CLIM will (rightly) think the output records position is at the +;; first output. This is not good, because it means that the output +;; record will "walk" across the screen if the buffer starts with +;; blanks. Therefore, we make sure that an output record exists at the +;; very beginning of the output. +(defmethod display-drei-contents :before ((stream extended-output-stream) (drei drei-area) syntax) + (with-new-output-record (stream 'standard-sequence-output-record record) + (setf (output-record-position record) (stream-cursor-position stream)))) + (defgeneric display-drei-cursor (stream drei cursor syntax) (:documentation "Display the given cursor to `stream'.") (:method :around ((stream extended-output-stream) (drei drei) From thenriksen at common-lisp.net Thu Nov 9 00:52:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 8 Nov 2006 19:52:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061109005201.C11022B0E1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11264/Drei Modified Files: drei-redisplay.lisp Log Message: Slight change of how full-redisplay works and fix of docstring (oops). --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/08 17:52:55 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/09 00:52:01 1.3 @@ -420,8 +420,7 @@ (if (full-redisplay-p drei-pane) (progn (reposition-pane drei-pane) (adjust-pane-bot drei-pane) - (setf (full-redisplay-p drei-pane) nil) - (window-clear drei-pane)) + (setf (full-redisplay-p drei-pane) nil)) (adjust-pane drei-pane)) (update-syntax-for-display buffer (syntax buffer) top bot) (display-drei-contents drei-pane drei-pane (syntax buffer)) @@ -432,8 +431,7 @@ (fix-pane-viewport drei-pane))) (defgeneric full-redisplay (pane) - (:documentation "Return T if `pane' is queued to do a full -redisplay, NIL otherwise.")) + (:documentation "Queue a full redisplay for `pane'.")) (defmethod full-redisplay ((pane drei-pane)) (setf (full-redisplay-p pane) t)) From thenriksen at common-lisp.net Thu Nov 9 00:53:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 8 Nov 2006 19:53:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061109005321.0102E2B13C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11341/Drei Modified Files: lisp-syntax.lisp Log Message: Minor fix for supporting multiple views of same parse tree on same stream. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/08 17:52:55 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/09 00:53:21 1.3 @@ -1866,13 +1866,12 @@ (defmethod display-parse-tree ((parser-symbol literal-object-lexeme) stream (drei drei) (syntax lisp-syntax)) (updating-output - (stream :unique-id (list stream parser-symbol) + (stream :unique-id (list drei parser-symbol) :id-test #'equal :cache-value parser-symbol :cache-test #'eql) (let ((object (token-to-object syntax parser-symbol))) - (present object - (presentation-type-of object) :stream stream)))) + (present object (presentation-type-of object) :stream stream)))) (defmethod display-parse-tree ((parser-symbol lisp-lexeme) stream (drei drei) (syntax lisp-syntax)) @@ -1883,7 +1882,7 @@ (eq (slot-value t1 'face) (text-style-face (medium-text-style (sheet-medium stream))))))) (updating-output - (stream :unique-id (list stream parser-symbol) + (stream :unique-id (list drei parser-symbol) :id-test #'equal :cache-value parser-symbol :cache-test #'cache-test) From dlichteblau at common-lisp.net Thu Nov 9 20:24:21 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Thu, 9 Nov 2006 15:24:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061109202421.188B156043@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22752 Modified Files: sheets.lisp Log Message: revert previous checkins, putting magic 100 and #x10000 values back in --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/11/05 15:40:15 1.52 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2006/11/09 20:24:20 1.53 @@ -671,16 +671,17 @@ ;; the server, since it is not under our control. ((or (null (sheet-parent sheet)) (null (sheet-parent (sheet-parent sheet)))) + (make-rectangle* 0 0 #x10000 #x10000) + #+nil (make-rectangle* 0 0 (port-mirror-width (port sheet) sheet) (port-mirror-height (port sheet) sheet))) (t ;; For other sheets just use the calculated value, saves a round trip. (or (%sheet-mirror-region sheet) - ;; ... unless we don't have it yet. - (make-rectangle* 0 0 - (port-mirror-width (port sheet) sheet) - (port-mirror-height (port sheet) sheet)) )))) + ;; XXX what to do if the sheet has no idea about its region? + ;; XXX can we consider calling sheet-mirror-region then an error? + (make-rectangle* 0 0 #x10000 #x10000) )))) (defmethod sheet-native-transformation ((sheet mirrored-sheet-mixin)) ;; XXX hm... From dlichteblau at common-lisp.net Thu Nov 9 20:24:21 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Thu, 9 Nov 2006 15:24:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20061109202421.521DB56043@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv22752/Backends/CLX Modified Files: port.lisp Log Message: revert previous checkins, putting magic 100 and #x10000 values back in --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/11/05 15:35:26 1.124 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2006/11/09 20:24:21 1.125 @@ -337,7 +337,7 @@ mirror-region))) (defun realize-mirror-aux (port sheet - &key width height (x 0) (y 0) + &key (width 100) (height 100) (x 0) (y 0) (border-width 0) (border 0) (override-redirect :off) (map t) @@ -367,10 +367,12 @@ (pixel (xlib:alloc-color (xlib:screen-default-colormap (clx-port-screen port)) color)) (window (xlib:create-window :parent (sheet-mirror (sheet-parent sheet)) - :width (or width - (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet)))) - :height (or height - (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet)))) + :width (if (%sheet-mirror-region sheet) + (round-coordinate (bounding-rectangle-width (%sheet-mirror-region sheet))) + width) + :height (if (%sheet-mirror-region sheet) + (round-coordinate (bounding-rectangle-height (%sheet-mirror-region sheet))) + height) :x (if (%sheet-mirror-transformation sheet) (round-coordinate (nth-value 0 (transform-position (%sheet-mirror-transformation sheet) From thenriksen at common-lisp.net Fri Nov 10 01:15:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 9 Nov 2006 20:15:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061110011558.797C510DC@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7476/Drei Modified Files: input-editor.lisp Log Message: Add somewhat-correct implementation of input-editor typeout. I believe Hefner has a better idea for how this should work. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/08 13:08:12 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/10 01:15:58 1.3 @@ -523,6 +523,45 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; `With-input-editor-typeout' +;;; +;;; The CLIM spec is very vague about what this function is supposed +;;; to do, but the Franz users guide suggests that it is to be used to +;;; display information to the user while editing, sort of what we +;;; normally use a minibuffer for. Perhaps the output should be put in +;;; an output record above or below the editing area, but for now, we +;;; just put it in the minibuffer. That also means the `:erase' +;;; keyword argument is meaningless. We do add some extra limitations, +;;; though (check the docstring) + +(defgeneric invoke-with-input-editor-typeout (stream continuation &key erase) + (:documentation "Call `continuation' with a single argument, a +stream to do input-editor-typeout on.")) + +(defmethod invoke-with-input-editor-typeout ((stream drei-input-editing-mixin) + (continuation function) &key erase) + (declare (ignore erase)) + (let ((drei (drei-instance stream))) + (when (minibuffer drei) + (funcall continuation (minibuffer drei))))) + +(defmacro with-input-editor-typeout ((&optional (stream t) &rest args + &key erase) + &body body) + "`Stream' is not evaluated and must be a symbol. If T (the +default), `*standard-input*' will be used. `Stream' will be bound +to an `extended-output-stream' while `body' is being evaluated." + (declare (ignore erase)) + (check-type stream symbol) + (let ((stream (if (eq stream t) *standard-input* stream))) + `(apply #'invoke-with-input-editor-typeout + ,stream + #'(lambda (,stream) + , at body) + ,args))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; Presentation type specialization. (define-presentation-method accept :around From thenriksen at common-lisp.net Fri Nov 10 16:46:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 11:46:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061110164651.3F78D6913D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6699/Drei Modified Files: drei-clim.lisp Log Message: Never let Drei have itself as the minibuffer. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/08 13:08:12 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/10 16:46:51 1.3 @@ -352,7 +352,9 @@ #+(or mcclim building-mcclim) (climi::arm-gadget drei t))) (defmethod execute-drei-command ((drei drei-gadget-pane) command) - (let* ((*minibuffer* (or *minibuffer* *standard-input*))) + (let* ((*minibuffer* (or *minibuffer* + (unless (eq drei *standard-input*) + *standard-input*)))) (accepting-from-user (drei) (execute-drei-command-for-frame (pane-frame drei) drei command)))) From thenriksen at common-lisp.net Fri Nov 10 16:47:16 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 11:47:16 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061110164716.0081A6B007@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv6767/Drei Modified Files: drei.lisp Log Message: CLHS says we're not supposed to use `print-object'. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/10 16:47:16 1.2 @@ -545,7 +545,7 @@ (user-condition-mixin (c) (beep) (with-minibuffer-stream (minibuffer) (let ((*print-escape* nil)) - (print-object c minibuffer)))))) + (princ c minibuffer)))))) (defmacro with-bound-drei-special-variables ((drei-instance &key current-buffer From thenriksen at common-lisp.net Fri Nov 10 18:22:04 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 13:22:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061110182204.C697453010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv21073 Modified Files: text-editor-gadget.lisp Log Message: A text field is single-line (in display), but it does not have an opinion about its maximum width. Implemented this behavior. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/08 01:18:22 1.1 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/10 18:22:04 1.2 @@ -54,9 +54,8 @@ (w (text-size medium (gadget-value pane)))) (let ((width w) (height (+ as ds))) - (make-space-requirement :width width :height height - :max-width width :max-height height - :min-width width :min-height height))))) + (make-space-requirement :height height :max-height height :min-height height + :min-width width :width width))))) (defmethod allocate-space ((pane text-field-pane) w h) (resize-sheet pane w h)) From thenriksen at common-lisp.net Fri Nov 10 18:36:57 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 13:36:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Examples Message-ID: <20061110183657.3ACB456008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv21577/Examples Modified Files: clim-fig.lisp Log Message: The text-field gadget is not supposed to be editable here. Also, this is actually not what this gadget is supposed to be used for. --- /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2004/02/07 14:05:50 1.28 +++ /project/mcclim/cvsroot/mcclim/Examples/clim-fig.lisp 2006/11/10 18:36:57 1.29 @@ -278,7 +278,8 @@ :activate-callback #'(lambda (x) (declare (ignore x)) (com-clear))) - (status :text-field :value "CLIM Fig")) + (status :text-field :value "CLIM Fig" + :editable-p nil)) (:layouts (default (vertically () From thenriksen at common-lisp.net Fri Nov 10 18:37:56 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 13:37:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061110183756.259045B019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21743/Drei Modified Files: drei.lisp Log Message: Add :editable-p initarg to Drei. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/10 16:47:16 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/10 18:37:56 1.3 @@ -476,7 +476,7 @@ :type (or minibuffer-pane null) :documentation "The minibuffer pane (or null) associated with the Drei instance.")) - (:default-initargs :active t) + (:default-initargs :active t :editable-p t) (:documentation "An abstract Drei class that should not be directly instantiated.")) @@ -485,10 +485,12 @@ (setf (active cursor) new-val)) (cursors drei))) -(defmethod initialize-instance :after ((object drei) &rest args &key active single-line) +(defmethod initialize-instance :after ((object drei) &rest args &key + active single-line (editable-p t)) (declare (ignore args)) (setf (single-line-p (implementation (buffer object))) single-line) (with-slots (buffer point mark top bot scan) object + (setf (read-only-p buffer) (not editable-p)) (setf point (clone-mark (point buffer))) (when (null point) (setf point (clone-mark (low-mark buffer) :right))) From thenriksen at common-lisp.net Fri Nov 10 18:39:46 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 13:39:46 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061110183946.202A360033@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21845/Drei Modified Files: drei-clim.lisp Log Message: :editable-p handling was moved to the `drei' class. We need to disable read-only status in `(setf gadget-value)'. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/10 16:46:51 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/10 18:39:45 1.4 @@ -297,9 +297,12 @@ (defmethod (setf gadget-value) (new-value (gadget drei-gadget-pane) &key (invoke-callback t)) - (performing-drei-operations (gadget :with-undo nil :redisplay nil) - (delete-buffer-range (buffer gadget) 0 (size (buffer gadget))) - (insert-buffer-sequence (buffer gadget) 0 new-value)) + ;; I think we're supposed to permit this, even if the buffer is + ;; non-editable. + (letf (((read-only-p (buffer gadget)) nil)) + (performing-drei-operations (gadget :with-undo nil :redisplay nil) + (delete-buffer-range (buffer gadget) 0 (size (buffer gadget))) + (insert-buffer-sequence (buffer gadget) 0 new-value))) (when invoke-callback (value-changed-callback gadget (gadget-client gadget) @@ -446,7 +449,7 @@ &rest args &key (syntax nil) (initial-contents "") (minibuffer t) (border-width 1) - (scroll-bars :horizontal) (editable-p t) + (scroll-bars :horizontal) (drei-class 'drei-gadget-pane)) (check-type initial-contents array) (check-type border-width integer) @@ -464,8 +467,8 @@ (drei-pane (apply #'make-pane-1 fm frame drei-class :minibuffer minibuffer-pane args)) (pane drei-pane)) - (insert-sequence (point drei-pane) initial-contents) - (setf (read-only-p (buffer drei-pane)) (not editable-p)) + (letf (((read-only-p (buffer drei-pane)) nil)) + (insert-sequence (point drei-pane) initial-contents)) (if syntax (setf (syntax (buffer drei-pane)) (make-instance (or (when (syntaxp syntax) From thenriksen at common-lisp.net Fri Nov 10 18:40:41 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 13:40:41 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061110184041.A62E660036@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv23353 Modified Files: text-editor-gadget.lisp Log Message: Handle :value initarg. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/10 18:22:04 1.2 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/10 18:40:41 1.3 @@ -46,6 +46,10 @@ (:default-initargs :activation-gestures *standard-activation-gestures*)) +(defmethod initialize-instance :after ((object text-field-pane) &key value) + ;; Why doesn't `value-gadget' do this for us? + (setf (gadget-value object) value)) + (defmethod compose-space ((pane text-field-pane) &key width height) (declare (ignore width height)) (with-sheet-medium (medium pane) @@ -74,6 +78,10 @@ :accessor text-editor-nlines)) (:default-initargs :activation-gestures nil)) +(defmethod initialize-instance :after ((object text-editor-pane) &key value) + ;; Why doesn't `value-gadget' do this for us? + (setf (gadget-value object) value)) + (defmethod make-pane-1 :around (fm (frame application-frame) (type (eql :text-editor)) &rest args &key) From thenriksen at common-lisp.net Sat Nov 11 00:08:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 10 Nov 2006 19:08:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061111000831.056624717F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12052/Drei Modified Files: drei-clim.lisp drei.lisp fundamental-syntax.lisp lisp-syntax.lisp packages.lisp syntax.lisp Log Message: Make syntax-specific command-table handling slightly more sophisticated (hooray for complexity). This is needed to support users with advanced needs, such as Climacs. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/10 18:39:45 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/11 00:08:30 1.5 @@ -32,74 +32,6 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; -;;; Drei command tables. - -;;; Commenting. -(make-command-table 'comment-table :errorp nil) -;;; Deleting. -(make-command-table 'deletion-table :errorp nil) -;;; Editing - making changes to a buffer. -(make-command-table 'editing-table :errorp nil) -;;; Filling. -(make-command-table 'fill-table :errorp nil) -;;; Dealing with charcase. -(make-command-table 'case-table :errorp nil) -;;; Indentation. -(make-command-table 'indent-table :errorp nil) -;;; Marking things. -(make-command-table 'marking-table :errorp nil) -;;; Moving around. -(make-command-table 'movement-table :errorp nil) -;;; Searching. -(make-command-table 'search-table :errorp nil) -;;; Information about buffer contents. -(make-command-table 'info-table :errorp nil) -;;; Self-insertion. -(make-command-table 'self-insert-table :errorp nil) - -;;; Command table for concrete editor stuff. -(define-syntax-command-table editor-table - :errorp nil - :inherit-from '(comment-table - deletion-table - editing-table - case-table - fill-table - indent-table - marking-table - movement-table - search-table - info-table - self-insert-table - keyboard-macro-table)) - -;; Command table for commands that are only available when Drei is a -;; pane. -(make-command-table 'exclusive-pane-table :errorp nil) - -;; Command table for input-editor-only commands. -(make-command-table 'exclusive-input-editor-table :errorp nil) - -(define-command (com-extended-command :command-table exclusive-pane-table) - () - "Prompt for a command name and arguments, then run it." - (let ((item (handler-case - (accept - `(command :command-table ,(command-table *current-window*)) - ;; this gets erased immediately anyway - :prompt "" :prompt-mode :raw) - ((or command-not-accessible command-not-present) () - (beep) - (display-message "No such command") - (return-from com-extended-command nil))))) - (execute-drei-command *current-window* item))) - -(set-key 'com-extended-command - 'exclusive-pane-table - '((#\x :meta))) - -;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; -;;; ;;; The Drei gadget and pane. ;;; ;;; An application can use Drei in two different ways - by using @@ -254,9 +186,6 @@ (setf space-width (text-size medium " " :text-style style) tab-width (* 8 space-width)))))) -(defmethod additional-command-tables append ((drei drei-pane) (table command-table)) - `(exclusive-pane-table)) - ;;; The fun is that in the gadget version of Drei, we do not control ;;; the application command loop, and in fact, need to operate ;;; completely independently of it - we can only act when the our port @@ -361,6 +290,10 @@ (accepting-from-user (drei) (execute-drei-command-for-frame (pane-frame drei) drei command)))) +(defmethod additional-command-tables append ((drei drei-gadget-pane) + (table drei-command-table)) + `(exclusive-gadget-table)) + (defclass drei-area (drei standard-sequence-output-record command-processor instant-macro-execution-mixin) @@ -392,7 +325,7 @@ (defmethod (setf active) :after (new-val (drei drei-area)) (replay drei (editor-pane drei))) -(defmethod additional-command-tables append ((drei drei-area) (table command-table)) +(defmethod additional-command-tables append ((drei drei-area) (table drei-command-table)) `(exclusive-input-editor-table)) (defclass drei-minibuffer-pane (minibuffer-pane) @@ -426,14 +359,6 @@ (defmethod display-drei (frame (instance drei-area)) (display-drei-area instance)) -(defgeneric command-table (drei) - (:documentation "Return the command table object used by the - Drei instance `drei'.")) - -(defmethod command-table ((drei drei)) - (find-command-table (or (command-table (syntax (buffer drei))) - 'editor-table))) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Programmer interface stuff --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/10 18:37:56 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/11 00:08:30 1.4 @@ -405,6 +405,96 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Drei command tables. + +;;; Commenting. +(make-command-table 'comment-table :errorp nil) +;;; Deleting. +(make-command-table 'deletion-table :errorp nil) +;;; Editing - making changes to a buffer. +(make-command-table 'editing-table :errorp nil) +;;; Filling. +(make-command-table 'fill-table :errorp nil) +;;; Dealing with charcase. +(make-command-table 'case-table :errorp nil) +;;; Indentation. +(make-command-table 'indent-table :errorp nil) +;;; Marking things. +(make-command-table 'marking-table :errorp nil) +;;; Moving around. +(make-command-table 'movement-table :errorp nil) +;;; Searching. +(make-command-table 'search-table :errorp nil) +;;; Information about buffer contents. +(make-command-table 'info-table :errorp nil) +;;; Self-insertion. +(make-command-table 'self-insert-table :errorp nil) + +;;; Command table for concrete editor stuff. +(define-syntax-command-table editor-table + :errorp nil + :inherit-from '(comment-table + deletion-table + editing-table + case-table + fill-table + indent-table + marking-table + movement-table + search-table + info-table + self-insert-table + keyboard-macro-table)) + +;; Command table for commands that are only available when Drei is a +;; gadget. There is no pane-exclusive table because the Drei pane is +;; not meant to be used as-is, but is meant to be subclassed, so we do +;; not want to force users to work around too much default behavior. +(make-command-table 'exclusive-gadget-table :errorp nil) + +;; Command table for input-editor-only commands. +(make-command-table 'exclusive-input-editor-table :errorp nil) + +(define-command (com-drei-extended-command :command-table exclusive-gadget-table) + () + "Prompt for a command name and arguments, then run it." + (let ((item (handler-case + (accept + `(command :command-table ,(command-table *current-window*)) + ;; this gets erased immediately anyway + :prompt "" :prompt-mode :raw) + ((or command-not-accessible command-not-present) () + (beep) + (display-message "No such command") + (return-from com-drei-extended-command nil))))) + (execute-drei-command *current-window* item))) + +(set-key 'com-drei-extended-command + 'exclusive-gadget-table + '((#\x :meta))) + +(defclass drei-command-table (standard-command-table) + () + (:documentation "This class is used to provide the kind of +indirection we need to support syntax-specific command tables in +Drei. Commands should *NOT* be added to it.")) + +(defmethod additional-command-tables append ((frame application-frame) + (command-table syntax-command-table)) + "This method allows users of Drei to extend syntaxes with new, +app-specific commands, as long as they inherit from a Drei class +and specialise a method for it." + (additional-command-tables *current-window* command-table)) + +(defmethod command-table-inherit-from ((table drei-command-table)) + (let ((syntax-table (command-table *current-syntax*))) + (list* syntax-table + (when (use-editor-commands-p syntax-table) + 'editor-table) + (additional-command-tables *current-window* table)))) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; The basic Drei class. (defclass drei () @@ -475,7 +565,15 @@ :initarg :minibuffer :type (or minibuffer-pane null) :documentation "The minibuffer pane (or null) -associated with the Drei instance.")) +associated with the Drei instance.") + (%command-table :initform (make-instance 'drei-command-table + :name 'drei-dispatching-table) + :reader command-table + :initarg :command-table + :type standard-command-table + :documentation "The command table used for +looking up commands for the Drei instance. Has a sensible +default, don't override it unless you know what you are doing.")) (:default-initargs :active t :editable-p t) (:documentation "An abstract Drei class that should not be directly instantiated.")) @@ -687,13 +785,6 @@ (execute-drei-command-for-frame (pane-frame (editor-pane drei)) drei command))) -(defmethod additional-command-tables append ((frame application-frame) - (command-table command-table)) - "This method allows users of Drei to extend syntaxes with new, -app-specific commands, as long as they inherit from a Drei class -and specialise a method for it." - (additional-command-tables *current-window* command-table)) - (defgeneric invoke-accepting-from-user (drei continuation) (:documentation "Set up `drei' and the environment so that calls to `accept' will behave properly. Then call --- /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/08 17:52:55 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/fundamental-syntax.lisp 2006/11/11 00:08:30 1.3 @@ -24,12 +24,19 @@ ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; +;;; Every syntax must have a command table. + +(define-syntax-command-table fundamental-table + :errorp nil) + +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; +;;; ;;; The syntax object and misc stuff. (define-syntax fundamental-syntax (syntax) ((lines :initform (make-instance 'standard-flexichain)) (scan :accessor scan)) - (:command-table editor-table) + (:command-table fundamental-table) (:name "Fundamental")) (defmethod initialize-instance :after ((syntax fundamental-syntax) &rest args) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/09 00:53:21 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/11 00:08:30 1.4 @@ -43,8 +43,7 @@ ;;; The command table. (define-syntax-command-table lisp-table - :errorp nil - :inherit-from '(editor-table)) + :errorp nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/11 00:08:30 1.2 @@ -132,7 +132,7 @@ (defpackage :drei-syntax (:use :clim-lisp :clim :drei-buffer :drei-base :flexichain :esa-utils) (:export #:syntax #:syntaxp #:define-syntax #:*default-syntax* #:cursor-positions - #:syntax-command-table #:additional-command-tables #:define-syntax-command-table + #:syntax-command-table #:use-editor-commands-p #:additional-command-tables #:define-syntax-command-table #:eval-option #:define-option-for-syntax #:current-attributes-for-syntax --- /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/syntax.lisp 2006/11/11 00:08:30 1.2 @@ -25,7 +25,7 @@ (defclass syntax (name-mixin) ((buffer :initarg :buffer :reader buffer) (command-table :initarg :command-table - :initform nil + :initform (error "A command table has not been provided for this syntax") :reader command-table) (%cursor-positions :accessor cursor-positions :initform nil))) @@ -74,6 +74,17 @@ available when Lisp syntax is used in Climacs (or another editor), but not anywhere else.")) +(defgeneric use-editor-commands-p (command-table) + (:documentation "If `command-table' is supposed to include +standard editor commands (for inserting objects, moving cursor, +etc), this function will return T (the default). If you want your +syntax to use standard editor commands, you should *not* inherit +from `editor-table' - the command tables containing the editor +commands will be added automatically, as long as this function +returns T.") + (:method ((command-table syntax-command-table)) + t)) + (defgeneric additional-command-tables (editor command-table) (:method-combination append) (:documentation "Get a list of additional command tables that @@ -240,20 +251,23 @@ ;; collide with user-defined syntax initargs. Use ;; DREI-SYNTAX::%NAME instead. (setf default-initargs (list* :name name default-initargs)) - (once-only (command-table) - `(progn - (push (make-syntax-description - :name ,name :class-name ',class-name - :pathname-types ',pathname-types) - *syntaxes*) - (defclass ,class-name ,superclasses ,slots - (:default-initargs :command-table (when (find-command-table ,command-table) - (if (find-class ,command-table nil) - (make-instance ,command-table :name ,command-table) - ;; It must be just a command table. - (find-command-table ,command-table))) - , at default-initargs) - , at defclass-options))))) + `(progn + (push (make-syntax-description + :name ,name :class-name ',class-name + :pathname-types ',pathname-types) + *syntaxes*) + (defclass ,class-name ,superclasses ,slots + ,(append '(:default-initargs) + (when command-table + (list :command-table + (once-only (command-table) + `(when (find-command-table ,command-table) + (if (find-class ,command-table nil) + (make-instance ,command-table :name ,command-table) + ;; It must be just a command table. + (find-command-table ,command-table)))))) + default-initargs) + , at defclass-options)))) (defgeneric eval-option (syntax name value) (:documentation "Evaluate the option `name' with the specified From thenriksen at common-lisp.net Sat Nov 11 15:33:21 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 11 Nov 2006 10:33:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061111153321.3EAC76F23E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv28429 Modified Files: Makefile Added Files: makeimages.sh mcclim.texi sheet-hierarchy.tex Removed Files: manual.tex Log Message: Converted McCLIM User's Guide to Texinfo format, but extracted one math-heavy (and not very user-oriented) chapter to an external LaTeX document (sheet-hierarchy.tex). --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2003/07/16 17:49:39 1.3 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/11 15:33:21 1.4 @@ -1,11 +1,17 @@ -NAME=manual +NAME=mcclim +NAME2=sheet-hierarchy -TEXFILES=$(NAME).tex $(shell ./tex-dependencies $(NAME).tex) +TEXFILES=$(NAME2).tex $(shell ./tex-dependencies $(NAME2).tex) PSTEX_T=$(shell ./strip-dependence inputfig $(TEXFILES)) VERBATIM=$(shell ./strip-dependence verbatimtabinput $(TEXFILES)) PSTEX=$(subst .pstex_t,.pstex,$(PSTEX_T)) +IMAGES=ex2.eps inspect-as-cells.eps inspect-object-1.eps \ +inspect-object-2.eps inspect-object-3.eps native.fig +IMAGETARGETTYPES=gif png eps +TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") +TEXIFILES=$(NAME).texi -all : $(NAME).ps +all : $(NAME).ps $(NAME2).ps %.pstex: %.fig fig2dev -Lpstex -m 0.75 $< $@ @@ -13,12 +19,24 @@ %.pstex_t: %.fig %.pstex fig2dev -Lpstex_t -m 0.75 -p $(basename $<).pstex $< $@ -$(NAME).dvi: $(TEXFILES) $(PSTEX_T) $(VERBATIM) +$(NAME).dvi: $(TEXIFILES) $(TARGETIMAGES) + texi2dvi $(NAME).texi + +$(NAME2).dvi: $(NAME2).tex $(PSTEX_T) $(VERBATIM) latex $< -# makeindex $(NAME) + makeindex $(NAME) latex $< -$(NAME).ps: $(NAME).dvi $(PSTEX) +$(TARGETIMAGES): + sh ./makeimages.sh "$(IMAGES)" "$(IMAGETARGETTYPES)" + +$(NAME).html: $(TEXIFILES) + makeinfo --html $< + +$(NAME).ps: $(NAME).dvi + dvips $< -o + +$(NAME2).ps: $(NAME2).dvi $(PSTEX) dvips $< -o view: $(NAME).ps @@ -29,5 +47,5 @@ spotless: make clean - rm -f *.ps *.dvi *.pstex *.pstex_t *.toc *.idx *.ilg *.ind - + rm -f *.ps *.dvi *.pstex *.pstex_t *.toc *.idx *.ilg *.ind *pdf \ +*ky *pg *tmp *tp *tps *vr *fn *fns *info --- /project/mcclim/cvsroot/mcclim/Doc/makeimages.sh 2006/11/11 15:33:21 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/makeimages.sh 2006/11/11 15:33:21 1.1 #!/bin/sh # Go through a list of image files and make sure that a version of # each image exists in every format specified by a list of file # types. Uses ImageMagick. If first argument is -e, to not convert, # but print a list of the files that are supposed to exist after the # script has run. if [ "$1" == "-e" ]; then NOCREATE="true" IMAGES="$2" IMAGETARGETTYPES="$3" else IMAGES=$1 IMAGETARGETTYPES=$2 fi for FILE in $IMAGES; do if [ -f "$FILE" ]; then RAWFILE=${FILE%.*} for TYPE in $IMAGETARGETTYPES; do FILETOMAKE=$RAWFILE.$TYPE if [ "$NOCREATE" == "true" ]; then echo $FILETOMAKE else if [ ! -f "$FILETOMAKE" ]; then convert $FILE $FILETOMAKE fi fi done else echo The file $FILE does not exist. fi done--- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/11 15:33:21 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/11 15:33:21 1.1 % @c -*- Coding: utf-8; Mode: Texinfo -*- % @c Note that Texinfo does not support UTF-8. Please do not use literal % @c UTF-8 characters in this document. \input texinfo @setfilename mcclim @settitle McCLIM User's Manual @set MCCLIMVERSION 0.9.3 @copying Copyright @copyright{} 2004,2005,2006 the McCLIM hackers. @end copying @dircategory Common Lisp @direntry * McCLIM User's Manual: (mcclim). A free implementation of CLIM. @end direntry @titlepage @title{McCLIM User's Manual} @sp 5 @center @titlefont{The Users Guide} @sp 2 @center @titlefont{and} @sp 2 @center @titlefont{API Reference} @sp 2 @page @vskip 0pt plus 1filll @insertcopying @end titlepage @iftex @contents @end iftex @macro glossentry{ENTRY} @b{\ENTRY\} @cindex \ENTRY\ @end macro @macro func{NAME} @t{\NAME\} @findex \NAME\ @end macro @macro fmacro{MACRO} @func{\MACRO\} @end macro @macro genfun{FUN} @func{\FUN\} @end macro @alias gloss = i @alias class = t @alias gadget = t @alias pane = t @alias initarg = t @alias methcomp = t @alias slot = t @alias longref = t @alias cl = t @alias initarg = t @ifnottex @node Top @top McCLIM User's Manual @insertcopying @end ifnottex @menu * Introduction:: Getting started * CLIM Demos and Applications:: * The First Application:: * Using presentation types:: User Manual * Using views:: * Using command tables:: Reference Manual * Concepts:: * Windowing system drawing functions:: * CLIM drawing functions:: * Panes:: * Output Protocol:: * Command Processing:: Extensions * Output Protocol Extensions:: * Output Recording Extensions:: * Drawing Two-Dimensional Images:: * File Selector Gadget:: * PostScript Backend:: Utility Programs * Listener:: * Inspector:: Auxilliary Material * Glossary:: * Development History:: Index * Concept Index:: * Function Index:: @end menu @node Introduction @chapter Introduction @cindex Ehtoota CLIM is a large layered software system that allows the user to customize it at each level. The most simple ways of using CLIM is to directly use its top layer, which contains application frames, panes, and gadgets, very similar to those of traditional windowing system toolkits such as GTK, Tk, and Motif. But there is much more to using CLIM. In CLIM, the upper layer with panes and gadgets is written on top of a basic layer containing more basic functionality in the form of sheets. Objects in the upper layer are typically instances of classes derived from those of the lower layer. Thus, nothing prevents a user from adding new gadgets and panes by writing code that uses the sheet layer. Finally, since CLIM is written in Common Lisp, essentially all parts of it can be modified, replaced, or extended. For that reason, a user's manual for CLIM must contain not only a description of the protocols of the upper layer, but also of all protocols, classes, functions, macros, etc. that are part of the specification. @menu * Standards:: * How CLIM Is Different:: @end menu @node Standards @section Standards This manual documents McCLIM @value{MCCLIMVERSION} which is a mostly complete implementation of the CLIM 2.0 specification and its revision 2.2. To our knowledge version~2.2 of the CLIM specification is only documented in the ``CLIM 2 User's Guide'' by Franz. While that document is not a formal specification, it does contain many cleanups and is often clearer than the official specification; on the other hand, the original specification is a useful reference. This manual will note where McCLIM has followed the 2.2 API. @cindex Specification Also, some protocols mentioned in the 2.0 specification, such as parts of the incremental redisplay protocol, are clearly internal to CLIM and not well described. It will be noted here when they are partially implemented in McCLIM or not implemented at all. @node How CLIM Is Different @section How CLIM Is Different Many new users of CLIM have a hard time trying to understand how it works and how to use it. A large part of the problem is that many such users are used to more traditional GUI toolkits, and they try to fit CLIM into their mental model of how GUI toolkits should work. But CLIM is much more than just a GUI toolkit, as suggested by its name, it is an @emph{interface manager}, i.e. it is a complete mediator between application ``business logic'' and the way the user interacts with objects of the application. In fact, CLIM doesn't have to be used with graphics output at all, as it contains a large collection of functionality to manage text. @cindex Interface manager Traditional GUI toolkits have an @emph{event loop}. @cindex Event loop Events are delivered to GUI elements called @emph{gadgets} (or @emph{widgets}), and the programmer attaches @emph{event handlers} to those gadgets in order to invoke the functionality of the application logic. While this way of structuring code is sometimes presented as a virtue (``Event-driven programming''), it has an unfortunate side effect, namely that event handlers are executed in a null context, so that it becomes hard to even remember two consecutive events. The effect of event-driven programming is that applications written that way have very rudimentary interaction policies. At the lowest level, CLIM also has an event loop, but most application programmers never have any reason to program at that level with CLIM. Instead, CLIM has a @emph{command loop} @cindex Command loop at a much higher level than the event loop. At each iteration of the command loop: @enumerate @item A command is acquired. You might satisfy this demand by clicking on a menu item, by typing the name of a command, by hitting some kind of keystroke, by pressing a button, or by pressing some visible object with a command associated with it; @item Arguments that are required by the command are acquired. Each argument is often associated with a @emph{presentation type}, and visible objects of the right presentation type can be clicked on to satisfy this demand. You can also type a textual representation of the argument, using completion, or you can use a context menu; @item The command is called on the arguments, usually resulting in some significant modification of the data structure representing your application logic; @item A @emph{display routine} is called to update the views of the application logic. The display routine may use features such as incremental redisplay. @end enumerate Instead of attaching event handlers to gadgets, writing a CLIM application therefore consists of: @itemize @bullet @item writing CLIM commands that modify the application data structures independently of how those commands are invoked, and which may take application objects as arguments; @item writing display routines that turn the application data structures (and possibly some "view" object) into a collection of visible representations (having presentation types) of application objects; @item writing completion routines that allow you to type in application objects (of a certain presentation type) using completions; @item independently deciding how commands are to be invoked (menus, buttons, presentations, textual commands, etc). @end itemize By using CLIM as a mediator of command invocation and argument acquisition, you can obtain some very modular code. Application logic is completely separate from interaction policies, and the two can evolve separately and independently. @c @node Getting Started @c @part Getting Started @node CLIM Demos and Applications @chapter CLIM Demos and Applications @cindex Demo applications @menu * Running the Demos:: * McCLIM Installation and Usage Tips:: @end menu @node Running the Demos @section Running the Demos The McCLIM source distribution comes with a number of demos and applications. They are intended to showcase specific CLIM features, demonstrate programming techniques or provide useful tools. These demos and applications are available in the @t{Examples} and @t{Apps} subdirectories of the source tree's root directory. Instructions for compiling, loading and running some of the demos are included in the files with the McCLIM installation instructions for your Common Lisp implementation. See for example the file @t{INSTALL} if you use Allegro CL, @t{INSTALL.CMU} for CMUCL, @t{INSTALL.OPENMCL} for OpenMCL, and so on. Below is a complete list of the McCLIM demos and applications, sorted in alphabetical order. Each entry provides a short description of what the program does, with instructions for compiling and running it if not mentioned in the general installation instructions. @table @t @item Apps/Listener CLIM-enabled Lisp listener. See the compilation and execution instructions in @t{Apps/Listener/README}. @item Examples/address-book.lisp Simple address book. See McCLIM's installation instructions. @item Examples/calculator.lisp Simple desk calculator. See McCLIM's installation instructions. @item Examples/clim-fig.lisp Simple paint program. You can run it by evaluating this form at the Lisp prompt: @lisp (clim-demo::clim-fig) @end lisp @item Examples/colorslider.lisp Interactive color editor. See McCLIM's installation instructions. @item Examples/demodemo.lisp Demonstrates different pane types. You can compile it by evaluating: @lisp (compile-file "Examples/demodemo.lisp") @end lisp Then load it with: @lisp (load "Examples/demodemo") @end lisp Finally, run it with: @lisp (clim-demo::demodemo) @end lisp @item Examples/goatee-test.lisp Text editor with Emacs-like key bindings. See McCLIM's installation instructions. @item Examples/menutest.lisp Displays a window with a simple menu bar. See McCLIM's installation instructions. @item Examples/postscript-test.lisp Displays text and graphics to a PostScript file. Run it with: @lisp (clim-demo::postscript-test) @end lisp The resulting file @t{ps-test.ps} is generated in the current directory and can be displayed by a PostScript viewer such as @t{gv} on Unix-like systems. @item Examples/presentation-test.lisp Displays an interactive window in which you type numbers that are successively added. When a number is expected as input, you can either type it at the keyboard, or click on a previously entered number. Run it with: @lisp (clim:run-frame-top-level (clim:make-application-frame 'clim-demo::summation)) @end lisp @item Examples/sliderdemo.lisp Apparently a calculator demo (see above). Compile with: @lisp (compile-file "Examples/sliderdemo.lisp") @end lisp Load with: @lisp (load "Examples/sliderdemo") @end lisp Run with: @lisp (clim-demo::slidertest) @end lisp @item Examples/stream-test.lisp Interactive command processor that echoes its input. Run with: @lisp (clim-demo::run-test) @end lisp @end table The following programs are currently @b{known not to work}: @itemize @bullet @item @t{Examples/fire.lisp} @item @t{Examples/gadget-test-kr.lisp} @item @t{Examples/gadget-test.lisp} @item @t{Examples/puzzle.lisp} @item @t{Examples/traffic-lights.lisp} @item @t{Examples/transformations-test.lisp} @end itemize @node McCLIM Installation and Usage Tips @section McCLIM Installation and Usage Tips [1945 lines skipped] --- /project/mcclim/cvsroot/mcclim/Doc/sheet-hierarchy.tex 2006/11/11 15:33:21 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/sheet-hierarchy.tex 2006/11/11 15:33:21 1.1 [2451 lines skipped] From thenriksen at common-lisp.net Sat Nov 11 20:11:51 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 11 Nov 2006 15:11:51 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061111201151.57C825D009@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30070 Modified Files: packages.lisp Log Message: Change #:exclusive-pane-table to #:exclusive-gadget-table. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/11 00:08:30 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/11 20:11:51 1.3 @@ -200,7 +200,7 @@ #:comment-table #:deletion-table #:editing-table #:fill-table #:indent-table #:marking-table #:case-table #:movement-table #:search-table #:info-table #:self-insert-table - #:editor-table #:exclusive-pane-table #:exclusive-input-editor-table + #:editor-table #:exclusive-gadget-table #:exclusive-input-editor-table ;; DREI interface stuff. #:drei #:drei-pane #:drei-gadget-pane #:drei-area From dlichteblau at common-lisp.net Sun Nov 12 11:26:13 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 06:26:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061112112613.6C85B14008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3215 Modified Files: event.lisp gtk-ffi.lisp port.lisp Log Message: Fix issue reported by C Y on cffi-devel, 2006-11-11: Use the documented gdk_error_trap_push() instead of internal variables. * gtk-ffi.lisp (_gdk_error_warnings, _gdk_error_code): Removed. (gdk_error_trap_push, gdk_error_trap_pop): New declarations. * event.lisp (dribble-x-errors): Pop the previous error, push a new handler. * port.lisp (initialize-instance): Push a handler. Misc: * port.lisp (*old-frontend-size-hack*): Removed. (mirror-drawable): Don't bind *o-f-s-h*. (port-mirror-width, port-mirror-height): Don't obey *o-f-s-h*. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/05 18:43:19 1.10 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 11:26:13 1.11 @@ -87,12 +87,13 @@ (defun dribble-x-errors () #-(or win32 windows mswindows) - (unless (zerop *-gdk-error-code*) - (warn "Ignoring X error ~D: ~A" - *-gdk-error-code* - (cffi:with-foreign-pointer-as-string (buf 64) - (XGetErrorText *gdk-display* *-gdk-error-code* buf 63))) - (setf *-gdk-error-code* 0))) + (let ((code (gdk_error_trap_pop))) + (unless (zerop code) + (warn "Ignoring X error ~D: ~A" + code + (cffi:with-foreign-pointer-as-string (buf 64) + (XGetErrorText *gdk-display* code buf 63)))) + (gdk_error_trap_push))) ;; thread-safe entry function (defun gtk-main-iteration (port &optional block) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/05 21:23:11 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 11:26:13 1.12 @@ -133,8 +133,8 @@ ;;; Error handling: -(cffi:defcvar "_gdk_error_warnings" :int) -(cffi:defcvar "_gdk_error_code" :int) +(defcfun "gdk_error_trap_push" :void) +(defcfun "gdk_error_trap_pop" :int) #-(or win32 mswindows windows) (cffi:defcfun "XGetErrorText" --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/05 21:23:12 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/12 11:26:13 1.8 @@ -76,7 +76,7 @@ (g_thread_init (cffi:null-pointer)) (gdk_threads_init) #-(or win32 windows mswindows) - (setf *-gdk-error-warnings* 0)) + (gdk_error_trap_push)) (with-gtk () ;; FIXME: hier koennten wir mindestens ein anderes --display uebergeben ;; wenn wir wollten @@ -135,14 +135,11 @@ (defvar *double-buffering-p* t) -(defparameter *old-frontend-size-hack* t) - (defmethod mirror-drawable ((mirror widget-mirror)) (if *double-buffering-p* (or (mirror-buffering-pixmap mirror) (setf (mirror-buffering-pixmap mirror) - (let* ((*old-frontend-size-hack* nil) - (window (mirror-real-drawable mirror)) + (let* ((window (mirror-real-drawable mirror)) (region (climi::sheet-mirror-region (climi::port-lookup-sheet (mirror-port mirror) @@ -644,22 +641,18 @@ (error "port-string-width called, what now?")) (defmethod port-mirror-width ((port gtkairo-port) sheet) - (if *old-frontend-size-hack* - #x10000 - (cffi:with-foreign-object (r 'gtkrequisition) - (gtk_widget_size_request - (mirror-widget (climi::port-lookup-mirror port sheet)) - r) - (cffi:foreign-slot-value r 'gtkrequisition 'width)))) + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'width))) (defmethod port-mirror-height ((port gtkairo-port) sheet) - (if *old-frontend-size-hack* - #x10000 - (cffi:with-foreign-object (r 'gtkrequisition) - (gtk_widget_size_request - (mirror-widget (climi::port-lookup-mirror port sheet)) - r) - (cffi:foreign-slot-value r 'gtkrequisition 'height)))) + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request + (mirror-widget (climi::port-lookup-mirror port sheet)) + r) + (cffi:foreign-slot-value r 'gtkrequisition 'height))) (defmethod port-mirror-width ((port gtkairo-port) (sheet gtkairo-graft)) (graft-width sheet)) From dlichteblau at common-lisp.net Sun Nov 12 11:45:21 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 06:45:21 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061112114521.8EDFF4717F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv5980 Modified Files: port.lisp Log Message: * port.lisp (*double-buffering-p*): By default, enable double buffering only on Windows. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/12 11:26:13 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/port.lisp 2006/11/12 11:45:21 1.9 @@ -133,7 +133,9 @@ (defmethod mirror-real-drawable ((mirror widget-mirror)) (gtkwidget-gdkwindow (mirror-widget mirror))) -(defvar *double-buffering-p* t) +(defvar *double-buffering-p* + #+(or win32 windows mswindows) t + #-(or win32 windows mswindows) nil) (defmethod mirror-drawable ((mirror widget-mirror)) (if *double-buffering-p* From dlichteblau at common-lisp.net Sun Nov 12 11:46:09 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 06:46:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061112114609.2D8ED48144@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6064 Modified Files: NEWS Log Message: Update NEWS file with recent Gtkairo changes. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/02 19:45:26 1.2 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 11:46:09 1.3 @@ -1,5 +1,8 @@ * Changes in mcclim-0.9.4 relative to 0.9.3: ** cleanup: removed the obsolete system.lisp file. +** backend improvements: Gtkairo +*** Double buffering is now supported (fixes disappearing widgets on Windows). +*** X errors no longer terminate the lisp process. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From dlichteblau at common-lisp.net Sun Nov 12 13:46:08 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 08:46:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061112134608.6FDCF54121@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv29396 Modified Files: NEWS Log Message: "Maybe later" Implement native context menus by injecting a callback for invocation in the event loop, instead of popping them up in frame-manager-menu-choose, which GTK+ does not like at all. * gtk-ffi.lisp (g_idle_add): New declaration. * frame-manager.lisp (FRAME-MANAGER-MENU-CHOOSE): Enable this definition. Call `gtk_menu_popup' through INVOKE-LATER. Recognize context-menu-cancelled-event. Remove unused variables. * gadgets.lisp (CONTEXT-MENU-CANCELLED-EVENT): New class. (DESTRUCTURE-MC-MENU-ITEM): Assume type :ITEM if the plist doesn't specify otherwise. (MAKE-CONTEXT-MENU): Install a handler for signal `deactivate'. * event.lisp (*LAST-SEEN-BUTTON*): New variable. (BUTTON-HANDLER): Record the last button that got pressed. (POPUP-DEACTIVATED-HANDLER): New callback. (INVOKE-LATER, IDLE-FUNCTION, *LATER-TABLE*, *LATER-COUNTER*): New definitions. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 11:46:09 1.3 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 13:46:08 1.4 @@ -3,6 +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. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From dlichteblau at common-lisp.net Sun Nov 12 13:46:09 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 08:46:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061112134609.941635600C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv29396/Backends/gtkairo Modified Files: event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp Log Message: "Maybe later" Implement native context menus by injecting a callback for invocation in the event loop, instead of popping them up in frame-manager-menu-choose, which GTK+ does not like at all. * gtk-ffi.lisp (g_idle_add): New declaration. * frame-manager.lisp (FRAME-MANAGER-MENU-CHOOSE): Enable this definition. Call `gtk_menu_popup' through INVOKE-LATER. Recognize context-menu-cancelled-event. Remove unused variables. * gadgets.lisp (CONTEXT-MENU-CANCELLED-EVENT): New class. (DESTRUCTURE-MC-MENU-ITEM): Assume type :ITEM if the plist doesn't specify otherwise. (MAKE-CONTEXT-MENU): Install a handler for signal `deactivate'. * event.lisp (*LAST-SEEN-BUTTON*): New variable. (BUTTON-HANDLER): Record the last button that got pressed. (POPUP-DEACTIVATED-HANDLER): New callback. (INVOKE-LATER, IDLE-FUNCTION, *LATER-TABLE*, *LATER-COUNTER*): New definitions. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 11:26:13 1.11 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 13:46:08 1.12 @@ -246,12 +246,15 @@ :modifier-state (gdkmodifiertype->modifier-state state) :timestamp time)))))))) +(defvar *last-seen-button* 3) + (define-signal button-handler (widget event) (cffi:with-foreign-slots ((type time button state x y x_root y_root) event gdkeventbutton) (when (eql type GDK_BUTTON_PRESS) ;; Hack alert: Menus don't work without this. (gdk_pointer_ungrab GDK_CURRENT_TIME)) + (setf *last-seen-button* button) (enqueue (make-instance (if (eql type GDK_BUTTON_PRESS) 'pointer-button-press-event @@ -368,6 +371,12 @@ :value (dummy-menu-item-sheet-value dummy-item) :itemspec (dummy-menu-item-sheet-itemspec dummy-item))))) +(define-signal popup-deactivated-handler (widget (menu :pointer)) + menu + (enqueue + (make-instance 'context-menu-cancelled-event + :sheet (widget->sheet widget *port*)))) + #-sbcl (define-signal (scrollbar-change-value-handler :return-type :int) (widget (scroll gtkscrolltype) (value :double)) @@ -386,3 +395,19 @@ :value (sb-kernel:make-double-float hi lo) :sheet (widget->sheet widget *port*))) 1) + +(defvar *later-table* (make-hash-table)) +(defvar *later-counter* 0) + +(defun invoke-later (fun) + (with-gtk () + (let ((i (incf *later-counter*))) + (setf (gethash i *later-table*) fun) + (g_idle_add (cffi:get-callback 'idle-function) i)))) + +(cffi:defcallback idle-function :int + ((data :long)) ;hack + (let ((fun (gethash data *later-table*))) + (remhash data *later-table*) + (funcall fun)) + 0) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/05/13 19:37:29 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 13:46:08 1.5 @@ -116,15 +116,14 @@ (port-enable-sheet (car climi::*all-ports*) (slot-value frame 'climi::top-level-sheet))) -#+(or) ;doesn't work yet (defmethod frame-manager-menu-choose ((frame-manager gtkairo-frame-manager) items &key associated-window printer presentation-type - (default-item nil default-item-p) - text-style label cache unique-id id-test cache-value cache-test - max-width max-height n-rows n-columns x-spacing y-spacing row-wise - cell-align-x cell-align-y scroll-bars pointer-documentation) + (default-item nil default-item-p) + text-style label cache unique-id id-test cache-value cache-test + max-width max-height n-rows n-columns x-spacing y-spacing row-wise + cell-align-x cell-align-y scroll-bars pointer-documentation) (declare ;; XXX hallo? (ignore printer presentation-type default-item default-item-p @@ -136,16 +135,27 @@ (pane-frame associated-window) *application-frame*)) (port (port frame)) - (tls (slot-value frame 'climi::top-level-sheet)) - (tls-mirror (climi::port-lookup-mirror port tls)) (sheet (make-instance 'dummy-context-menu-sheet)) (menu (make-context-menu port sheet items))) - (gtk_menu_popup menu - (cffi:null-pointer) - (cffi:null-pointer) - (cffi:null-pointer) - (cffi:null-pointer) - 0 - (gtk_get_current_event_time)) + (invoke-later + (lambda () + (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME))) + (gtk_menu_popup menu + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + (cffi:null-pointer) + *last-seen-button* + (gtk_get_current_event_time)))) (let ((event (event-read sheet))) - (values (event-value event) (event-itemspec event) event)))) + ;; `deactivate' is signalled on the menu before `clicked' on the item, + ;; so let's make sure we have processed all events before deciding + ;; whether the was a `clicked' or not + (gtk-main-iteration port) + (when (typep (event-peek sheet) 'context-menu-clicked-event) + (setf event (event-read sheet))) + (etypecase event + (context-menu-clicked-event + (values (event-value event) (event-itemspec event) event)) + (context-menu-cancelled-event + nil))))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/06/10 10:08:49 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 13:46:08 1.7 @@ -33,6 +33,8 @@ ((value :initarg :value :accessor event-value) (itemspec :initarg :itemspec :accessor event-itemspec))) +(defclass context-menu-cancelled-event (gadget-event) ()) + ;;;; Classes @@ -163,7 +165,7 @@ (&key value style items documentation active type) (cdr x) (declare (ignore style documentation active)) - (values (if items :menu type) + (values (cond (items :menu) (type) (t :item)) (car x) (or value (car x)) items))))) @@ -208,6 +210,8 @@ (gtk_menu_item_set_submenu item menu) item))))) (gtk_menu_shell_append menu gtkmenuitem)))) + (setf (widget->sheet menu port) sheet) + (connect-signal menu "deactivate" 'popup-deactivated-handler) (gtk_widget_show_all menu) menu)) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 11:26:13 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 13:46:08 1.13 @@ -776,6 +776,13 @@ (rect :pointer) (childrenp :int)) +(defcfun "g_idle_add" + :int + (fun :pointer) + ;; hack + ;; (data :pointer) + (data :long)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) From thenriksen at common-lisp.net Sun Nov 12 17:55:40 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 12 Nov 2006 12:55:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061112175540.D02B9751B2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31622 Modified Files: NEWS Log Message: Added mention of Drei. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 13:46:08 1.4 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 17:55:40 1.5 @@ -4,6 +4,7 @@ *** Double buffering is now supported (fixes disappearing widgets on Windows). *** X errors no longer terminate the lisp process. *** Native implementation of context menus. +** Improvement: Added new editor substrate ("Drei"). * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From dlichteblau at common-lisp.net Sun Nov 12 20:12:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 15:12:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061112201219.87958751B1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17778 Modified Files: NEWS Log Message: Native list panes. * event.lisp (VIEW-SELECTION-CALLBACK): New. * frame-manager.lisp ((MAKE-PANE-2 GENERIC-LIST-PANE)): New. * gadgets.lisp (GTK-LIST, LIST-SELECTION-EVENT, +G-TYPE-STRING+, UNINSTALL-SCROLLER-PANE, LIST-PANE-SELECTION, (REALIZE-NATIVE-WIDGET GTK-LIST), GTK-LIST-SELECT-VALUE, GTK-LIST-RESET-SELECTION, ((SETF GADGET-VALUE) GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST), *LIST-SELECTION-RESULT*, LIST-SELECTION-CALLBACK, (HANDLE-EVENT LIST-SELECTION-EVENT)): New. * gtk-ffi.lisp (gtktreeiter, gvalue): New structs. (gtkselectionmode): New enum. (gtk_tree_view_new_with_model, gtk_list_store_newv, gtk_list_store_append, gtk_list_store_set_value, g_value_init, g_value_set_string, gtk_cell_renderer_text_new, gtk_tree_view_column_new, gtk_tree_view_column_get_widget, gtk_tree_view_column_set_widget, gtk_tree_view_column_pack_start, gtk_tree_view_insert_column, gtk_tree_view_column_add_attribute, gtk_tree_view_column_set_title, gtk_scrolled_window_new, gtk_tree_view_get_hadjustment, gtk_tree_view_get_vadjustment, gtk_tree_view_get_selection, gtk_tree_selection_set_mode, gtk_tree_selection_unselect_all, gtk_tree_selection_select_path, gtk_tree_path_new_from_indices, gtk_tree_path_free, gtk_tree_selection_set_select_function, gtk_tree_path_get_indices, gtk_tree_selection_selected_foreach): New declarations. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 17:55:40 1.5 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/12 20:12:19 1.6 @@ -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. +*** Native implementation of context menus and list panes. ** Improvement: Added new editor substrate ("Drei"). * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: From dlichteblau at common-lisp.net Sun Nov 12 20:12:19 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 15:12:19 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061112201219.CA0A07615E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv17778/Backends/gtkairo Modified Files: event.lisp frame-manager.lisp gadgets.lisp gtk-ffi.lisp Log Message: Native list panes. * event.lisp (VIEW-SELECTION-CALLBACK): New. * frame-manager.lisp ((MAKE-PANE-2 GENERIC-LIST-PANE)): New. * gadgets.lisp (GTK-LIST, LIST-SELECTION-EVENT, +G-TYPE-STRING+, UNINSTALL-SCROLLER-PANE, LIST-PANE-SELECTION, (REALIZE-NATIVE-WIDGET GTK-LIST), GTK-LIST-SELECT-VALUE, GTK-LIST-RESET-SELECTION, ((SETF GADGET-VALUE) GTK-LIST), (CONNECT-NATIVE-SIGNALS GTK-LIST), *LIST-SELECTION-RESULT*, LIST-SELECTION-CALLBACK, (HANDLE-EVENT LIST-SELECTION-EVENT)): New. * gtk-ffi.lisp (gtktreeiter, gvalue): New structs. (gtkselectionmode): New enum. (gtk_tree_view_new_with_model, gtk_list_store_newv, gtk_list_store_append, gtk_list_store_set_value, g_value_init, g_value_set_string, gtk_cell_renderer_text_new, gtk_tree_view_column_new, gtk_tree_view_column_get_widget, gtk_tree_view_column_set_widget, gtk_tree_view_column_pack_start, gtk_tree_view_insert_column, gtk_tree_view_column_add_attribute, gtk_tree_view_column_set_title, gtk_scrolled_window_new, gtk_tree_view_get_hadjustment, gtk_tree_view_get_vadjustment, gtk_tree_view_get_selection, gtk_tree_selection_set_mode, gtk_tree_selection_unselect_all, gtk_tree_selection_select_path, gtk_tree_path_new_from_indices, gtk_tree_path_free, gtk_tree_selection_set_select_function, gtk_tree_path_get_indices, gtk_tree_selection_selected_foreach): New declarations. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 13:46:08 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 20:12:19 1.13 @@ -411,3 +411,15 @@ (remhash data *later-table*) (funcall fun)) 0) + +(cffi:defcallback view-selection-callback :int + ((selection :pointer) + (model :pointer) + (path :pointer) + (isselected :int) + (data :pointer)) + selection model path isselected + (when (boundp '*port*) ;kludge + (let ((sheet (widget->sheet data *port*))) + (enqueue (make-instance 'list-selection-event :sheet sheet)))) + 1) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 13:46:08 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:12:19 1.6 @@ -93,6 +93,9 @@ ((:some-of nil) 'gtk-check-button)) initargs)) +(defmethod make-pane-2 ((type (eql 'clim:generic-list-pane)) &rest initargs) + (apply #'make-instance 'gtk-list initargs)) + (defmethod adopt-frame :after ((fm gtkairo-frame-manager) (frame application-frame)) ()) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 13:46:08 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 20:12:19 1.8 @@ -35,6 +35,8 @@ (defclass context-menu-cancelled-event (gadget-event) ()) +(defclass list-selection-event (gadget-event) ()) + ;;;; Classes @@ -45,6 +47,10 @@ (defclass gtk-check-button (native-widget-mixin toggle-button) ()) (defclass gtk-radio-button (native-widget-mixin toggle-button) ()) +(defclass gtk-list (native-widget-mixin list-pane climi::meta-list-pane) + ((title :initarg :title :initform "" :accessor list-pane-title) + (tree-view :accessor list-pane-tree-view))) + (defclass native-slider (native-widget-mixin climi::slider-gadget) ((climi::show-value-p :type boolean :initform nil @@ -80,6 +86,104 @@ (gtk_toggle_button_set_active widget (if (gadget-value sheet) 1 0)) widget)) +(defconstant +g-type-string+ (ash 16 2)) + +(defun uninstall-scroller-pane (pane) + (with-slots (climi::scroll-bar + climi::vscrollbar climi::hscrollbar + climi::x-spacing climi::y-spacing) + pane + (setf scroll-bar nil) + (when climi::vscrollbar + (sheet-disown-child pane climi::vscrollbar) + (setf climi::vscrollbar nil)) + (when climi::hscrollbar + (sheet-disown-child pane climi::hscrollbar) + (setf climi::hscrollbar nil)) + (setf climi::x-spacing 0) + (setf climi::y-spacing 0) + (let ((r (sheet-region pane))) + (allocate-space pane + (bounding-rectangle-width r) + (bounding-rectangle-height r))))) + +(defun list-pane-selection (sheet) + (gtk_tree_view_get_selection (list-pane-tree-view sheet))) + +(defmethod realize-native-widget ((sheet gtk-list)) + (cffi:with-foreign-object (types :ulong 2) + (setf (cffi:mem-aref types :long 0) +g-type-string+) + (setf (cffi:mem-aref types :long 1) 0) + (let* ((model (gtk_list_store_newv 1 types)) + (tv (gtk_tree_view_new_with_model model)) + (name-key (climi::list-pane-name-key sheet)) + (column (gtk_tree_view_column_new)) + (renderer (gtk_cell_renderer_text_new))) + (setf (list-pane-tree-view sheet) tv) + (gtk_tree_view_column_pack_start column renderer 1) + (gtk_tree_view_insert_column tv column -1) + (gtk_tree_view_column_add_attribute column renderer "text" 0) + (gtk_tree_view_column_set_title column (list-pane-title sheet)) + (cffi:with-foreign-object (&iter 'gtktreeiter) + (dolist (i (climi::list-pane-items sheet)) + (gtk_list_store_append model &iter) + (cffi:with-foreign-string (n (funcall name-key i)) + (cffi:with-foreign-object (&value 'gvalue) + (setf (cffi:foreign-slot-value &value 'gvalue 'type) 0) + (g_value_init &value +g-type-string+) + (g_value_set_string &value n) + (gtk_list_store_set_value model &iter 0 &value))))) + (gtk_tree_selection_set_mode + (list-pane-selection sheet) + (if (eq (climi::list-pane-mode sheet) :exclusive) + :browse + :multiple)) + (gtk-list-reset-selection sheet) + (let ((ancestor + (and (sheet-parent sheet) (sheet-parent (sheet-parent sheet)))) + (result tv)) + (when (typep ancestor 'scroller-pane) + (uninstall-scroller-pane ancestor)) + (let ((wrapper (gtk_scrolled_window_new + (gtk_tree_view_get_hadjustment tv) + (gtk_tree_view_get_vadjustment tv)))) + (gtk_container_add wrapper tv) + (setf result wrapper)) + (setf (list-pane-tree-view sheet) tv) ;?! + (gtk_tree_selection_set_select_function + (list-pane-selection sheet) + (cffi:get-callback 'view-selection-callback) + result + (cffi:null-pointer)) + result)))) + +(defun gtk-list-select-value (sheet value) + (let ((path + (gtk_tree_path_new_from_indices + (position value + (climi::list-pane-items sheet) + :key (climi::list-pane-value-key sheet) + :test (climi::list-pane-test sheet)) + :int -1))) + (gtk_tree_selection_select_path (list-pane-selection sheet) path) + (gtk_tree_path_free path))) + +(defun gtk-list-reset-selection (sheet) + (gtk_tree_selection_unselect_all (list-pane-selection sheet)) + (let ((value (gadget-value sheet))) + (if (eq (climi::list-pane-mode sheet) :exclusive) + (gtk-list-select-value sheet value) + (dolist (v value) + (gtk-list-select-value sheet v))))) + +(defmethod (setf gadget-value) :after + (value (gadget gtk-list) &key invoke-callback) + (declare (ignore invoke-callback)) + (with-gtk () + (let ((mirror (sheet-direct-mirror gadget))) + (when mirror + (gtk-list-reset-selection gadget))))) + (defun make-scale (fn sheet) (let* ((min (df (gadget-min-value sheet))) (max (df (gadget-max-value sheet))) @@ -232,6 +336,10 @@ ;; no signals ) +(defmethod connect-native-signals ((sheet gtk-list) widget) + ;; no signals + ) + ;;;; Event handling @@ -285,6 +393,40 @@ ((pane gtk-nonmenu) (event magic-gadget-event)) (funcall (gtk-nonmenu-callback pane) pane nil)) +(defvar *list-selection-result*) + +(cffi:defcallback list-selection-callback :void + ((model :pointer) + (path :pointer) + (iter :pointer) + (data :pointer)) + model iter data + (setf (gethash (cffi:mem-ref (gtk_tree_path_get_indices path) :int 0) + *list-selection-result*) + t)) + +(defmethod handle-event + ((pane gtk-list) (event list-selection-event)) + (with-gtk () + (let ((*list-selection-result* (make-hash-table)) + (value-key (climi::list-pane-value-key pane))) + (gtk_tree_selection_selected_foreach + (list-pane-selection pane) + (cffi:get-callback 'list-selection-callback) + (cffi:null-pointer)) + (setf (gadget-value pane :invoke-callback t) + (if (eq (climi::list-pane-mode pane) :exclusive) + (loop + for i being each hash-key in *list-selection-result* + do (return + (funcall value-key + (elt (climi::list-pane-items pane) i)))) + (loop + for i from 0 + for value in (climi::list-pane-items pane) + when (gethash i *list-selection-result*) + collect (funcall value-key value))))))) + ;;; COMPOSE-SPACE --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 13:46:08 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/12 20:12:19 1.14 @@ -290,6 +290,17 @@ (max_aspect :double) (win_gravity :int)) +(cffi:defcstruct gtktreeiter + (stamp :int) + (user_data :pointer) + (user_data2 :pointer) + (user_data3 :pointer)) + +(cffi:defcstruct gvalue + (type :ulong) + (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) @@ -299,6 +310,9 @@ :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 @@ -783,6 +797,131 @@ ;; (data :pointer) (data :long)) +(defcfun "gtk_tree_view_new_with_model" + :pointer + (model :pointer)) + +(defcfun "gtk_list_store_newv" + :pointer + (columns :int) + (types :pointer)) + +(defcfun "gtk_list_store_append" + :void + (list_store :pointer) + (iter :pointer)) + +(defcfun "gtk_list_store_set_value" + :void + (list_store :pointer) + (iter :pointer) + (column :int) + (value :pointer)) + +(defcfun "g_value_init" + :pointer + (gvalue :pointer) + (gtype :ulong)) + +(defcfun "g_value_set_string" + :void + (gvalue :pointer) + (string :pointer)) + +(defcfun "gtk_cell_renderer_text_new" :pointer) + +(defcfun "gtk_tree_view_column_new" :pointer) + +(defcfun "gtk_tree_view_column_get_widget" + :pointer + (column :pointer)) + +(defcfun "gtk_tree_view_column_set_widget" + :void + (column :pointer) + (widget :pointer)) + +(defcfun "gtk_tree_view_column_pack_start" + :void + (column :pointer) + (cell :pointer) + (expand :int)) + +(defcfun "gtk_tree_view_insert_column" + :int + (treeview :pointer) + (column :pointer) + (position :int)) + +(defcfun "gtk_tree_view_column_add_attribute" + :void + (column :pointer) + (renderer :pointer) + (attribute :string) + (column-index :int)) + +(defcfun "gtk_tree_view_column_set_title" + :void + (column :pointer) + (title :string)) + +(defcfun "gtk_scrolled_window_new" + :pointer + (hadjustment :pointer) + (vadjustment :pointer)) + +(defcfun "gtk_tree_view_get_hadjustment" + :pointer + (tv :pointer)) + +(defcfun "gtk_tree_view_get_vadjustment" + :pointer + (tv :pointer)) + +(defcfun "gtk_tree_view_get_selection" + :pointer + (tv :pointer)) + +(defcfun "gtk_tree_selection_set_mode" + :void + (selection :pointer) + (mode gtkselectionmode)) + +(defcfun "gtk_tree_selection_unselect_all" + :void + (selection :pointer)) + +(defcfun "gtk_tree_selection_select_path" + :void + (selection :pointer) + (path :pointer)) + +(defcfun "gtk_tree_path_new_from_indices" + :pointer + (index :int) + &rest) + +(defcfun "gtk_tree_path_free" + :void + (path :pointer)) + +(defcfun "gtk_tree_selection_set_select_function" + :void + (selection :pointer) + (fun :pointer) + (data :pointer) + (destroynotify :pointer)) + +(defcfun "gtk_tree_path_get_indices" + :pointer + (path :pointer)) + +(defcfun "gtk_tree_selection_selected_foreach" + :void + (selection :pointer) + (fun :pointer) + (data :pointer)) + (defconstant GDK_EXPOSURE_MASK (ash 1 1)) (defconstant GDK_POINTER_MOTION_MASK (ash 1 2)) (defconstant GDK_POINTER_MOTION_HINT_MASK (ash 1 3)) From dlichteblau at common-lisp.net Sun Nov 12 20:37:14 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 12 Nov 2006 15:37:14 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061112203714.896D136017@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv21118 Modified Files: frame-manager.lisp gadgets.lisp Log Message: Print context menu items properly. * frame-manager.lisp (frame-manager-menu-choose): Pass PRINTER to MAKE-CONTEXT-MENU. * gadgets.lisp (make-context-menu): Use new argument PRINTER, or PRINT-MENU-ITEM, instead of PRINC-TO-STRING. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:12:19 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/frame-manager.lisp 2006/11/12 20:37:14 1.7 @@ -129,7 +129,7 @@ cell-align-x cell-align-y scroll-bars pointer-documentation) (declare ;; XXX hallo? - (ignore printer presentation-type default-item default-item-p + (ignore presentation-type default-item default-item-p text-style label cache unique-id id-test cache-value cache-test max-width max-height n-rows n-columns x-spacing y-spacing row-wise cell-align-x cell-align-y scroll-bars @@ -139,7 +139,7 @@ *application-frame*)) (port (port frame)) (sheet (make-instance 'dummy-context-menu-sheet)) - (menu (make-context-menu port sheet items))) + (menu (make-context-menu port sheet items :printer printer))) (invoke-later (lambda () (invoke-later (lambda () (gdk_pointer_ungrab GDK_CURRENT_TIME))) --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 20:12:19 1.8 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/12 20:37:14 1.9 @@ -284,12 +284,15 @@ (value :initarg :value :accessor dummy-menu-item-sheet-value) (itemspec :initarg :itemspec :accessor dummy-menu-item-sheet-itemspec))) -(defun make-context-menu (port sheet items) +(defun make-context-menu (port sheet items &key printer) (let ((menu (gtk_menu_new))) (dolist (itemspec items) (multiple-value-bind (type display-object value sub-items) (destructure-mc-menu-item itemspec) - (let* ((label (princ-to-string display-object)) + (let* ((label (with-output-to-string (s) + (funcall (or printer #'print-menu-item) + display-object + s))) (gtkmenuitem (ecase type (:divider From thenriksen at common-lisp.net Sun Nov 12 22:24:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 12 Nov 2006 17:24:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061112222427.F254A314C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv6151 Modified Files: mcclim.asd Log Message: Make sure dialog.lisp is loaded before builtin-commands.lisp. --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/08 01:19:02 1.33 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2006/11/12 22:24:27 1.34 @@ -233,8 +233,10 @@ "bordered-output" "presentation-defs" "dialog-views" "input-editing" "commands")) - (:file "builtin-commands" :depends-on ("table-formatting" "commands" "presentations" - "presentation-defs" "input-editing")))) + (:file "builtin-commands" :depends-on ("table-formatting" + "commands" "presentations" + "dialog" "presentation-defs" + "input-editing")))) (defsystem :esa-mcclim :depends-on (:clim-core) From thenriksen at common-lisp.net Mon Nov 13 18:33:06 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 13 Nov 2006 13:33:06 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061113183306.4A07936002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7760 Removed Files: editing-commands.lisp Log Message: This file doesn't seem to be used. From thenriksen at common-lisp.net Tue Nov 14 07:48:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 02:48:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114074831.10BEB2D06D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21453 Modified Files: drei.lisp drei-clim.lisp Log Message: Make use of `accepting-from-user' general (seems to work) and move definition of `display-drei' to drei.lisp --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/11 00:08:30 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/14 07:48:30 1.5 @@ -615,6 +615,10 @@ top (clone-mark (low-mark buffer) :left) bot (clone-mark (high-mark buffer) :right)))) +;; Main redisplay entry point. +(defgeneric display-drei (frame drei) + (:documentation "Display the given Drei instance.")) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Some standard building block machinery. @@ -754,6 +758,23 @@ (unwind-protect (progn , at body) ,@(remove-if #'null (mapcar #'third triple-list)))))))) +(defgeneric invoke-accepting-from-user (drei continuation) + (:documentation "Set up `drei' and the environment so that +calls to `accept' will behave properly. Then call +`continuation'.")) + +(defmethod invoke-accepting-from-user ((drei drei) (continuation function)) + ;; By default, everything should work. + (funcall continuation)) + +(defmacro accepting-from-user ((drei) &body body) + "Modidfy `drei' and the environment so that calls to `accept' +can be done to arbitrary streams from within `body'. Or, at +least, make sure the Drei instance will not be a problem. When +Drei calls a command, it will be wrapped in this macro, so it +should be safe to use `accept' within Drei commands." + `(invoke-accepting-from-user ,drei #'(lambda () , at body))) + ;;; Plain `execute-frame-command' is not good enough for us. Our ;;; event-handler method uses this function to invoke commands, note ;;; that it is also responsible for updating the syntax of the buffer @@ -774,7 +795,8 @@ (handling-drei-conditions ;; Must be a list of buffers, so wrap in call to `list'. (with-undo ((list buffer)) - (execute-frame-command frame command)) + (accepting-from-user (drei-instance) + (execute-frame-command frame command))) (setf (previous-command drei-instance) command) (update-syntax buffer (syntax buffer)) (when (modified-p buffer) @@ -784,20 +806,3 @@ (let ((*standard-input* (or *minibuffer* *standard-input*))) (execute-drei-command-for-frame (pane-frame (editor-pane drei)) drei command))) - -(defgeneric invoke-accepting-from-user (drei continuation) - (:documentation "Set up `drei' and the environment so that -calls to `accept' will behave properly. Then call -`continuation'.")) - -(defmethod invoke-accepting-from-user ((drei drei) (continuation function)) - ;; By default, everything should work. - (funcall continuation)) - -(defmacro accepting-from-user ((drei) &body body) - "Modidfy `drei' and the environment so that calls to `accept' -can be done to arbitrary streams from within `body'. Or, at -least, make sure the Drei instance will not be a problem. When -Drei calls a command, it will be wrapped in this macro, so it -should be safe to use `accept' within Drei commands." - `(invoke-accepting-from-user ,drei #'(lambda () , at body))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/11 00:08:30 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/14 07:48:30 1.6 @@ -287,8 +287,7 @@ (let* ((*minibuffer* (or *minibuffer* (unless (eq drei *standard-input*) *standard-input*)))) - (accepting-from-user (drei) - (execute-drei-command-for-frame (pane-frame drei) drei command)))) + (execute-drei-command-for-frame (pane-frame drei) drei command))) (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) @@ -344,20 +343,17 @@ (:documentation "A constellation of a Drei gadget instance and a minibuffer.")) -(defgeneric display-drei (frame instance) - (:documentation "Display the given Drei instance.")) - -(defmethod display-drei (frame (instance drei-pane)) +(defmethod display-drei (frame (drei drei-pane)) (declare (ignore frame)) - (display-drei-pane instance (active instance))) + (display-drei-pane drei (active drei))) -(defmethod display-drei :after (frame (instance drei)) - (with-accessors ((minibuffer minibuffer)) instance - (when (and minibuffer (not (eq minibuffer (editor-pane instance)))) +(defmethod display-drei :after (frame (drei drei)) + (with-accessors ((minibuffer minibuffer)) drei + (when (and minibuffer (not (eq minibuffer (editor-pane drei)))) (redisplay-frame-pane (pane-frame minibuffer) minibuffer)))) -(defmethod display-drei (frame (instance drei-area)) - (display-drei-area instance)) +(defmethod display-drei (frame (drei drei-area)) + (display-drei-area drei)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Tue Nov 14 07:58:38 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 02:58:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114075838.102FB2D01D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23671 Modified Files: base.lisp Log Message: Add more convenience features: `as-region', `as-full-region', `extract-line', `lines-in-region', `extract-lines-in-region'. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/14 07:58:37 1.2 @@ -32,6 +32,45 @@ (in-package :drei-base) +(defgeneric invoke-as-region (mark1 mark2 continuation) + (:documentation "Invoke `continuation' with two arguments +ordering a proper region.")) + +(defmethod invoke-as-region ((mark1 integer) (mark2 integer) + (continuation function)) + (if (>= mark2 mark1) + (funcall continuation mark1 mark2) + (funcall continuation mark2 mark1))) + +(defmethod invoke-as-region ((mark1 mark) (mark2 mark) + (continuation function)) + (if (mark>= mark2 mark1) + (funcall continuation mark1 mark2) + (funcall continuation mark2 mark1))) + +(defmacro as-region ((mark1 mark2) &body body) + "Rebind `mark1' and `mark2' to be a proper region. That +is, `(mark>= mark2 mark1)' will hold. `Mark1' and `mark2' must be +symbols bound to marks or integers (but they must be of the same +type). It is a good idea to use this macro when dealing with +regions." + `(invoke-as-region ,mark1 ,mark2 + #'(lambda (,mark1 ,mark2) + , at body))) + +(defmacro as-full-region ((mark1 mark2) &body body) + "Bind `mark1' and `mark2' to marks that delimit a full + region (a region where the beginning and end are at the + beginning and end of their lines, respectively). The new marks + will be copies of the marks `mark1' and `mark2' are already + bound to. `Mark1' and `mark2' must be symbols bound to marks." + `(as-region (,mark1 ,mark2) + (let ((,mark1 (clone-mark ,mark1)) + (,mark2 (clone-mark ,mark2))) + (beginning-of-line ,mark1) + (end-of-line ,mark2) + , at body))) + (defmacro as-offsets ((&rest marks) &body body) "Bind the symbols in `marks' to the numeric offsets of the mark @@ -75,16 +114,15 @@ `(progn (let* ((,mark-sym (clone-mark ,mark1)) (,mark2-sym (clone-mark ,mark2))) - (when (mark< ,mark2-sym ,mark-sym) - (rotatef ,mark-sym ,mark2-sym)) - (loop while (and (mark<= ,mark-sym ,mark2-sym) - (not (end-of-buffer-p ,mark-sym))) - do - (let ((,line-var (clone-mark ,mark-sym))) - , at body) - (end-of-line ,mark-sym) - (unless (end-of-buffer-p ,mark-sym) - (forward-object ,mark-sym))))))) + (as-region (,mark-sym ,mark2-sym) + (loop while (and (mark<= ,mark-sym ,mark2-sym) + (not (end-of-buffer-p ,mark-sym))) + do + (let ((,line-var (clone-mark ,mark-sym))) + , at body) + (end-of-line ,mark-sym) + (unless (end-of-buffer-p ,mark-sym) + (forward-object ,mark-sym)))))))) (defgeneric previous-line (mark &optional column count) (:documentation "Move a mark up `count' lines conserving @@ -161,6 +199,66 @@ (end-of-line mark) (delete-region offset mark))))) +(defgeneric extract-line (mark &key from-end whole-line as-string) + (:documentation "Destructively remove part of a line and return +it. The line `mark' is in indicates which line to perform the +extraction on. The line contents from the beginning of the line +up to `mark' will be deleted and returned as a vector. If +`from-end' is true, the line contents from the end of the line to +`mark' will be affected instead. If `whole-line' is true, the +entire line, including any single ending newline character, will +be deleted and returned.")) + +(defun extract-whole-line (mark) + "Extract the whole line `mark' is in, and remove any single + trailing newline." + (let* ((border-mark (clone-mark mark)) + eol-offset) + (end-of-line border-mark) + (setf eol-offset (offset border-mark)) + (unless (end-of-buffer-p border-mark) + (incf eol-offset)) + (beginning-of-line border-mark) + (let ((sequence (region-to-sequence border-mark eol-offset))) + (delete-region border-mark eol-offset) + sequence))) + +(defmethod extract-line ((mark mark) &key from-end whole-line) + (if whole-line + (extract-whole-line mark) + (let ((border-mark (clone-mark mark))) + (if from-end + (end-of-line border-mark) + (beginning-of-line border-mark)) + (as-region (mark border-mark) + (let ((sequence (region-to-sequence mark border-mark))) + (delete-region mark border-mark) + sequence))))) + +(defgeneric lines-in-region (mark1 mark2) + (:documentation "Return a list of all the lines (not including + newline characters) in the full region delimited by `mark1' and + `mark2'.")) + +(defmethod lines-in-region (mark1 mark2) + (as-full-region (mark1 mark2) + (let (result) + (do-buffer-region-lines (line-mark mark1 mark2) + (let ((bol-offset (offset line-mark))) + (end-of-line line-mark) + (push (region-to-sequence bol-offset line-mark) result))) + result))) + +(defgeneric extract-lines-in-region (mark1 mark2) + (:documentation "Delete the lines of the full region delimited +by `mark1' and `mark2'")) + +(defmethod extract-lines-in-region ((mark1 mark) (mark2 mark)) + (as-full-region (mark1 mark2) + (let ((lines (lines-in-region mark1 mark2))) + (delete-region mark1 mark2) + lines))) + (defun empty-line-p (mark) "Check whether the mark is in an empty line." (and (beginning-of-line-p mark) (end-of-line-p mark))) @@ -212,21 +310,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2)))) (defmethod number-of-lines-in-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (buffer-number-of-lines-in-region (buffer mark2) offset1 offset2))) + (as-region (offset1 offset2) + (buffer-number-of-lines-in-region (buffer mark2) offset1 offset2)))) (defmethod number-of-lines-in-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (buffer-number-of-lines-in-region (buffer mark1) offset1 offset2)))) (defun constituentp (obj) "A predicate to ensure that an object is a constituent character." @@ -506,21 +601,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (downcase-buffer-region (buffer mark1) offset1 offset2)))) (defmethod downcase-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark2) offset1 offset2))) + (as-region (offset1 offset2) + (downcase-buffer-region (buffer mark2) offset1 offset2)))) (defmethod downcase-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (downcase-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (downcase-buffer-region (buffer mark1) offset1 offset2)))) (defun upcase-buffer-region (buffer offset1 offset2) (do-buffer-region (object offset buffer offset1 offset2) @@ -536,21 +628,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (upcase-buffer-region (buffer mark1) offset1 offset2)))) (defmethod upcase-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark2) offset1 offset2))) + (as-region (offset1 offset2) + (upcase-buffer-region (buffer mark2) offset1 offset2)))) (defmethod upcase-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (upcase-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (upcase-buffer-region (buffer mark1) offset1 offset2)))) (defun capitalize-buffer-region (buffer offset1 offset2) (let ((previous-char-constituent-p nil)) @@ -572,21 +661,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (capitalize-buffer-region (buffer mark1) offset1 offset2)))) (defmethod capitalize-region ((offset1 integer) (mark2 mark)) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark2) offset1 offset2))) + (as-region (offset1 offset2) + (capitalize-buffer-region (buffer mark2) offset1 offset2)))) (defmethod capitalize-region ((mark1 mark) (offset2 integer)) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (capitalize-buffer-region (buffer mark1) offset1 offset2))) + (as-region (offset1 offset2) + (capitalize-buffer-region (buffer mark1) offset1 offset2)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -618,21 +704,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defmethod tabify-region ((offset1 integer) (mark2 mark) tab-width) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (tabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))) (defmethod tabify-region ((mark1 mark) (offset2 integer) tab-width) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (tabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defun untabify-buffer-region (buffer offset1 offset2 tab-width) (loop for offset = offset1 then (1+ offset) @@ -656,21 +739,18 @@ (assert (eq (buffer mark1) (buffer mark2))) (let ((offset1 (offset mark1)) (offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) (defmethod untabify-region ((offset1 integer) (mark2 mark) tab-width) (let ((offset2 (offset mark2))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (untabify-buffer-region (buffer mark2) offset1 offset2 tab-width)))) (defmethod untabify-region ((mark1 mark) (offset2 integer) tab-width) (let ((offset1 (offset mark1))) - (when (> offset1 offset2) - (rotatef offset1 offset2)) - (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width))) + (as-region (offset1 offset2) + (untabify-buffer-region (buffer mark1) offset1 offset2 tab-width)))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Tue Nov 14 07:59:05 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 02:59:05 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114075905.B8B212D0B0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv23728 Modified Files: packages.lisp Log Message: Export the new convenience features from the `DREI-BASE' package. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/11 20:11:51 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 07:59:05 1.4 @@ -84,12 +84,17 @@ (defpackage :drei-base (:use :clim-lisp :drei-buffer :drei-kill-ring :esa-buffer :esa-utils) - (:export #:as-offsets + (:export #:as-region + #:as-full-region + #:as-offsets #:do-buffer-region #:do-buffer-region-lines #:previous-line #:next-line #:open-line #:delete-line + #:extract-line + #:lines-in-region + #:extract-lines-in-region #:empty-line-p #:line-indentation #:buffer-display-column From thenriksen at common-lisp.net Tue Nov 14 08:02:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 03:02:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114080227.EC73E3A016@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25373 Modified Files: core-commands.lisp Log Message: Add Sort Lines command. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 08:02:27 1.2 @@ -409,6 +409,27 @@ 'marking-table '((#\x :control) (#\x :control))) +(define-command (com-sort-lines :name t :command-table editing-table) + ((sort-ascending 'boolean :prompt "Sort in ascending order")) + "Sort the lines in the region delimited by current point and +mark. The lines will be lexicographically sorted, ignoring all +non-character objects in the lines. When the command is run, it +will ask whether to sort in ascending or descending order." + ;; I think the fastest thing is to extract all the lines to an list + ;; of lines, sort the list, and put the lines back in. The + ;; cons-memory overhead is probably smaller than writing an in-place + ;; sort algorithm (though the latter definitely wins on hack value). + (let ((lines (extract-lines-in-region *current-point* *current-mark*))) + (dolist (line (sort lines (if sort-ascending + #'string<= + #'string>=) + :key #'(lambda (line) + (coerce (remove-if-not #'character line) + 'string)))) + (insert-sequence *current-point* line) + (insert-object *current-point* #\Newline)) + (com-backward-delete-object 1 nil))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Kill-ring From thenriksen at common-lisp.net Tue Nov 14 10:17:13 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 05:17:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114101713.81FCD63043@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv8244 Modified Files: base.lisp Log Message: Whoops, removed extraneous keyword parameter. --- /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/14 07:58:37 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/base.lisp 2006/11/14 10:17:13 1.3 @@ -199,7 +199,7 @@ (end-of-line mark) (delete-region offset mark))))) -(defgeneric extract-line (mark &key from-end whole-line as-string) +(defgeneric extract-line (mark &key from-end whole-line) (:documentation "Destructively remove part of a line and return it. The line `mark' is in indicates which line to perform the extraction on. The line contents from the beginning of the line From thenriksen at common-lisp.net Tue Nov 14 10:31:37 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 05:31:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114103137.E5CC469006@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10285 Modified Files: basic-commands.lisp core-commands.lisp editing.lisp packages.lisp Log Message: Create object deletion/killing functions. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 10:31:37 1.2 @@ -371,13 +371,9 @@ "Delete the object after point. With a numeric argument, kill that many objects after (or before, if negative) point." - (let* ((point *current-point*) - (mark (clone-mark point))) - (forward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence point mark))) - (delete-region point mark))) + (if killp + (forward-kill-object *current-point* count) + (forward-delete-object *current-point* count))) (define-command (com-backward-delete-object :name t :command-table deletion-table) ((count 'integer :prompt "Number of Objects") @@ -385,13 +381,9 @@ "Delete the object before point. With a numeric argument, kills that many objects before (or after, if negative) point." - (let* ((point *current-point*) - (mark (clone-mark point))) - (backward-object mark count) - (when killp - (kill-ring-standard-push *kill-ring* - (region-to-sequence mark point))) - (delete-region mark point))) + (if killp + (backward-kill-object *current-point* count) + (backward-delete-object *current-point* count))) ;; We require somewhat special behavior from Kill Line, so define a ;; new function and use that to implement the Kill Line command. --- /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 08:02:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/core-commands.lisp 2006/11/14 10:31:37 1.3 @@ -428,7 +428,7 @@ 'string)))) (insert-sequence *current-point* line) (insert-object *current-point* #\Newline)) - (com-backward-delete-object 1 nil))) + (backward-delete-object *current-point*))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/14 10:31:37 1.2 @@ -196,7 +196,64 @@ ;;; ;;; Object editing +(defun forward-delete-object (mark &optional (count 1) limit-action) + "Kill `count' objects beginning from `mark'." + (let ((offset (offset mark))) + (handler-case (progn (forward-object mark count) + (delete-region offset mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + count "object" nil)))))) + +(defun backward-delete-object (mark &optional (count 1) limit-action) + "Kill `count' objects backwards beginning from `mark'." + (let ((offset (offset mark))) + (handler-case (progn (backward-object mark count) + (delete-region offset mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + +(defun forward-kill-object (mark &optional (count 1) concatenate-p limit-action) + "Kill `count' objects beginning from `mark'." + (let ((start (offset mark))) + (handler-case (progn (forward-object mark count) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push + *kill-ring* (region-to-sequence start mark)) + (kill-ring-reverse-concatenating-push + *kill-ring* (region-to-sequence start mark))) + (kill-ring-standard-push + *kill-ring* (region-to-sequence start mark))) + (delete-region start mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + +(defun backward-kill-object (mark &optional (count 1) concatenate-p limit-action) + "Kill `count' objects backwards beginning from `mark'." + (let ((start (offset mark))) + (handler-case (progn (forward-object mark count) + (if concatenate-p + (if (plusp count) + (kill-ring-concatenating-push + *kill-ring* (region-to-sequence start mark)) + (kill-ring-reverse-concatenating-push + *kill-ring* (region-to-sequence start mark))) + (kill-ring-standard-push + *kill-ring* (region-to-sequence start mark))) + (delete-region start mark)) + (invalid-motion () + (when limit-action + (funcall limit-action mark (offset mark) + (- count) "object" nil)))))) + (defun transpose-objects (mark) + "Transpose two objects at `mark'." (unless (beginning-of-buffer-p mark) (when (end-of-line-p mark) (backward-object mark)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 07:59:05 1.4 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/14 10:31:37 1.5 @@ -329,7 +329,11 @@ (defpackage :drei-editing (:use :clim-lisp :drei-base :drei-buffer :drei-syntax :drei-motion :drei :drei-kill-ring) - (:export #:transpose-objects + (:export #:forward-delete-object + #:backward-delete-object + #:forward-kill-object + #:backward-kill-object + #:transpose-objects ;; Lines #:forward-delete-line #:backward-delete-line From thenriksen at common-lisp.net Tue Nov 14 12:27:53 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 07:27:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114122753.59C6E52002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29521/Drei Modified Files: lisp-syntax-swine.lisp lisp-syntax-commands.lisp Log Message: The Compile Definition command is not going to work properly in standalone Drei. Move to Climacs. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/14 12:27:53 1.2 @@ -1080,24 +1080,3 @@ (result (apply #'format nil "~{{~:[No values~;~:*~{~S~^,~}~]}~}" values))) (esa:display-message result))))) - -(defun compile-definition-interactively (mark syntax) - (let* ((token (definition-at-mark mark syntax)) - (string (token-string syntax token)) - (m (clone-mark mark)) - (buffer-name (name (buffer syntax))) - (*read-base* (base syntax))) - (with-syntax-package (syntax mark) - (forward-definition m syntax) - (backward-definition m syntax) - (multiple-value-bind (result notes) - (compile-form-for-drei (get-usable-image syntax) - (token-to-object syntax token - :read t - :package (package-at-mark syntax mark)) - (buffer syntax) - m) - (show-note-counts notes (second result)) - (when (not (null notes)) - (show-notes notes buffer-name - (one-line-ify (subseq string 0 (min (length string) 20))))))))) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/14 12:27:53 1.2 @@ -184,12 +184,6 @@ (rotatef mark point)) (eval-region mark point *current-syntax*))) -(define-command (com-compile-definition :name t :command-table pane-lisp-table) - () - "Compile and load definition at point." - (evaluating-interactively - (compile-definition-interactively *current-point* *current-syntax*))) - (define-command (com-eval-last-expression :name t :command-table pane-lisp-table) ((insertp 'boolean :prompt "Insert?")) "Evaluate the expression before point in the local Lisp image." @@ -281,10 +275,6 @@ 'pane-lisp-table '((#\c :control) (#\r :control))) -(set-key 'com-compile-definition - 'pane-lisp-table - '((#\c :control) (#\c :control))) - (set-key `(com-eval-last-expression ,*numeric-argument-p*) 'pane-lisp-table '((#\c :control) (#\e :control))) From thenriksen at common-lisp.net Tue Nov 14 18:44:27 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 13:44:27 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Doc Message-ID: <20061114184427.8510D59081@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Doc In directory clnet:/tmp/cvs-serv27277 Modified Files: Makefile mcclim.texi Added Files: drei.texi Log Message: Added preliminary Drei documentation. --- /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/11 15:33:21 1.4 +++ /project/mcclim/cvsroot/mcclim/Doc/Makefile 2006/11/14 18:44:27 1.5 @@ -9,7 +9,7 @@ inspect-object-2.eps inspect-object-3.eps native.fig IMAGETARGETTYPES=gif png eps TARGETIMAGES=$(shell sh ./makeimages.sh -e "$(IMAGES)" "$(IMAGETARGETTYPES)") -TEXIFILES=$(NAME).texi +TEXIFILES=$(NAME).texi drei.texi all : $(NAME).ps $(NAME2).ps @@ -31,7 +31,7 @@ sh ./makeimages.sh "$(IMAGES)" "$(IMAGETARGETTYPES)" $(NAME).html: $(TEXIFILES) - makeinfo --html $< + makeinfo --html $(NAME).texi $(NAME).ps: $(NAME).dvi dvips $< -o --- /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/11 15:33:21 1.1 +++ /project/mcclim/cvsroot/mcclim/Doc/mcclim.texi 2006/11/14 18:44:27 1.2 @@ -43,11 +43,6 @@ @cindex \ENTRY\ @end macro - at macro func{NAME} - at t{\NAME\} - at findex \NAME\ - at end macro - @macro fmacro{MACRO} @func{\MACRO\} @end macro @@ -57,15 +52,15 @@ @end macro @alias gloss = i - at alias class = t - at alias gadget = t - at alias pane = t - at alias initarg = t + at alias class = code + at alias package = code + at alias gadget = code + at alias pane = code @alias methcomp = t - at alias slot = t + at alias slot = code @alias longref = t - at alias cl = t - at alias initarg = t + at alias cl = code + at alias initarg = code @ifnottex @node Top @@ -77,45 +72,47 @@ * Introduction:: Getting started -* CLIM Demos and Applications:: -* The First Application:: +* CLIM Demos and Applications:: +* The First Application:: * Using presentation types:: -User Manual -* Using views:: +User Manual +* Using views:: * Using command tables:: Reference Manual -* Concepts:: -* Windowing system drawing functions:: -* CLIM drawing functions:: -* Panes:: -* Output Protocol:: +* Concepts:: +* Windowing system drawing functions:: +* CLIM drawing functions:: +* Panes:: +* Output Protocol:: * Command Processing:: Extensions -* Output Protocol Extensions:: -* Output Recording Extensions:: +* Output Protocol Extensions:: +* Output Recording Extensions:: * Drawing Two-Dimensional Images:: * File Selector Gadget:: * PostScript Backend:: +* Drei:: -Utility Programs -* Listener:: +Utility Programs +* Listener:: * Inspector:: -Auxilliary Material +Auxilliary Material * Glossary:: * Development History:: Index * Concept Index:: +* Variable Index:: * Function Index:: @end menu @node Introduction @chapter Introduction - at cindex Ehtoota + at cindex ehtoota CLIM is a large layered software system that allows the user to customize it at each level. The most simple ways of using CLIM is to @@ -154,7 +151,7 @@ often clearer than the official specification; on the other hand, the original specification is a useful reference. This manual will note where McCLIM has followed the 2.2 API. - at cindex Specification + at cindex specification Also, some protocols mentioned in the 2.0 specification, such as parts of the incremental redisplay protocol, are clearly internal to CLIM and @@ -175,10 +172,10 @@ with objects of the application. In fact, CLIM doesn't have to be used with graphics output at all, as it contains a large collection of functionality to manage text. - at cindex Interface manager + at cindex interface manager Traditional GUI toolkits have an @emph{event loop}. - at cindex Event loop + at cindex event loop Events are delivered to GUI elements called @emph{gadgets} (or @emph{widgets}), and the programmer attaches @emph{event handlers} to those gadgets in order to invoke the functionality of the application @@ -191,8 +188,8 @@ At the lowest level, CLIM also has an event loop, but most application programmers never have any reason to program at that level with CLIM. -Instead, CLIM has a @emph{command loop} - at cindex Command loop +Instead, CLIM has a @emph{command loop} + at cindex command loop at a much higher level than the event loop. At each iteration of the command loop: @@ -248,7 +245,7 @@ @node CLIM Demos and Applications @chapter CLIM Demos and Applications - at cindex Demo applications + at cindex demo applications @menu * Running the Demos:: @@ -376,7 +373,7 @@ @node Multiprocessing with CMUCL @subsection Multiprocessing with CMUCL - at cindex Multiprocessing + at cindex multiprocessing Before beginning a McCLIM session with CMUCL, @b{you are strongly advised} to initialize multiprocessing by evaluating the form: @@ -411,8 +408,8 @@ @node The First Application @chapter The First Application - at cindex Building an application - at cindex Writing an application + at cindex building an application + at cindex writing an application @menu * Panes and Gadgets:: @@ -433,8 +430,8 @@ CLIM gadgets are @gadget{button}s, @gadget{slider}s, etc, and typical panes are the layout panes such as @pane{hbox}, @pane{vbox}, @pane{hrack}, etc. - at cindex Pane - at cindex Gadget + at cindex pane + at cindex gadget @node Defining Application Frames @section Defining Application Frames @@ -447,7 +444,7 @@ your application-specific data in slots in the application frame (rather than, say, in global variables), and to define your application-specific application frame in its own package. - at cindex Application frame + at cindex application frame The usual way to define an application frame is to use the macro @fmacro{define-application-frame}. This macro works much like @@ -468,11 +465,12 @@ package, here a package named @t{APP}. While not required, putting the application in its own package is good practice. -The package for the application uses two packages: @t{CLIM} and - at t{CLIM-LISP}. The @t{CLIM} package is the one that contains all the -symbols needed for using CLIM. The @t{CLIM-LISP} package replaces the - at t{COMMON-LISP} package for CLIM applications. It is essentially the -same as the @t{COMMON-LISP} package as far as the user is concerned. +The package for the application uses two packages: @package{CLIM} and + at package{CLIM-LISP}. The @package{CLIM} package is the one that +contains all the symbols needed for using CLIM. The @package{CLIM-LISP} +package replaces the @package{COMMON-LISP} package for CLIM +applications. It is essentially the same as the @package{COMMON-LISP} +package as far as the user is concerned. In our example, we export the symbol that corresponds to the main function to start our application, here called @t{APP-MAIN}. @@ -493,8 +491,10 @@ frame. These slots are typically used for holding all application-specific data. The current instance of the application frame will always be the value of the special variable - at t{*application-frame*}, so that the values of these slots can be -accessed. In our example, we do not initially have any further slots. + at t{*application-frame*}, + at vindex *application-frame* +so that the values of these slots can be accessed. In our example, we +do not initially have any further slots. The rest of the definition of an application frame contains additional elements that CLIM will allow the user to define. In our example, we @@ -555,8 +555,8 @@ With the option @t{:display-time nil}, the pane is never cleared, and output is accumulated every time we execute the @t{parity} command. -For this example, let us also add a few @emph{commands}. - at cindex Command +For this example, let us also add a few @emph{commands}. + at cindex command Such commands are defined by the use of a macro called @fmacro{@t{define-}@i{name}@t{-command}}, where @i{name} is the name of the application, in our case @t{superapp}. This macro is automatically @@ -617,7 +617,7 @@ at all times, and that is modified by the commands of the application. CLIM allows for a very easy way to write such an application. The main idea is to store the data structure in slots of the application frame, -and to use a @emph{display function} +and to use a @emph{display function} @cindex display function that after each iteration of the command loop displays the entire data structure to the application pane. @@ -630,7 +630,7 @@ @end lisp Here, we have added a slot that is called @t{current-number} to the -application frame. It is initialized to @t{NIL} and it has an accessor +application frame. It is initialized to @cl{NIL} and it has an accessor function that allow us to query and to modify the value. Observe that in this example, we no longer have the option @@ -655,7 +655,7 @@ that will result in output. This makes it possible for the same function to be used by several different frames, should that be called for. In our simple example, the display function only displays the -value of a single number (or @t{NIL}), but you could think of this as +value of a single number (or @cl{NIL}), but you could think of this as displaying all the objects that have been drawn in some figure drawing program or displaying all the entries in an address book. @@ -730,7 +730,7 @@ @node Using presentation types @chapter Using presentation types - at cindex Presentation type + at cindex presentation type @menu * What is a presentation type:: @@ -811,7 +811,7 @@ @node Using views @chapter Using views - at cindex View + at cindex view The CLIM specification mentions a concept called a @emph{view}, and also lists a number of predefined views to be used in various different @@ -877,7 +877,7 @@ @node Using command tables @chapter Using command tables - at cindex Command table + at cindex command table (to be filled in) @@ -900,17 +900,17 @@ The coordinate system used for the arguments of drawing functions is called the @gloss{user coordinate system}, - at cindex User coordinate system + at cindex user coordinate system and coordinate values expressed in the user coordinate system are known as @gloss{user coordinates}. - at cindex User coordinates + at cindex user coordinates Each sheet has its own coordinate system called the @gloss{sheet coordinate system}, - at cindex Sheet coordinate system + at cindex sheet coordinate system and positions expressed in this coordinate system are said to be expressed in @gloss{sheet coordinates}. - at cindex Sheet coordinates + at cindex sheet coordinates User coordinates are translated to @gloss{sheet coordinates} by means of the @gloss{user transformation} also called the @gloss{medium transformation}. This transformation is stored in the @gloss{medium} @@ -1043,7 +1043,7 @@ @node Panes @chapter Panes - at cindex Pane + at cindex pane Panes are subclasses of sheets. Some panes are @gloss{layout panes} that determine the size and position of its children according to rules @@ -1107,7 +1107,7 @@ @node Layout protocol @section Layout protocol - at cindex Layout protocol + at cindex layout protocol There is a set of fundamental rules of CLIM dividing responsibility between a parent pane and a child pane, with respect to the size and @@ -1296,9 +1296,9 @@ @node Command Processing @chapter Command Processing - at cindex Command - at cindex Command processing - at cindex Command tables + at cindex command + at cindex command processing + at cindex command tables @deffn {Macro} {define-command-table} name &key inherit-from menu inherit-menu @findex define-command-table @@ -1320,7 +1320,7 @@ @node Output Protocol Extensions @chapter Output Protocol Extensions - at cindex Extensions + at cindex extensions @deffn {Generic Function} {medium-miter-limit} medium @end deffn @@ -1332,7 +1332,7 @@ @node Output Recording Extensions @chapter Output Recording Extensions - at cindex Extensions + at cindex extensions @menu * Standard classes:: @@ -1577,6 +1577,8 @@ Loads a description of a font from the specified AFM file. + at include drei.texi + @c @node Utility Programs @c @part Utility Programs @@ -1588,7 +1590,7 @@ @node Inspector @chapter Inspector - at cindex Inspector + at cindex inspector @cindex Clouseau The inspector, called ``Clouseau'', is used for interactively inspecting @@ -1773,7 +1775,7 @@ many of them there are. It's written @math{\overline {x}} @lisp -(defgeneric mean (sample) +(defgeneric mean (sample) (:documentation "The mean of the numbers in a statistical sample")) @@ -2297,16 +2299,21 @@ cosmetic fixes to McCLIM and also worked on a GTK-like gadget set. He finally started work to get the OpenGL backend operational. - at node Concept Index - at unnumbered Concept Index + at node {Concept Index} + at unnumbered {Concept Index} @printindex cp - at node Function Index - at unnumbered Function Index + at node {Variable Index} + at unnumbered {Variable Index} + + at printindex vr + + at node {Function And Macro Index} + at unnumbered {Function And Macro Index} @printindex fn - at bye [4 lines skipped] --- /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/11/14 18:44:27 NONE +++ /project/mcclim/cvsroot/mcclim/Doc/drei.texi 2006/11/14 18:44:27 1.1 [2726 lines skipped] From thenriksen at common-lisp.net Tue Nov 14 19:43:37 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 14 Nov 2006 14:43:37 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061114194337.433C87D193@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3441/Drei Modified Files: basic-commands.lisp Log Message: Reactivate the arrow keys. --- /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 10:31:37 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/basic-commands.lisp 2006/11/14 19:43:36 1.3 @@ -146,7 +146,7 @@ (set-key `(com-forward-object ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :right #-mcclim :right-arrow))) + '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow))) (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table @@ -154,7 +154,7 @@ (set-key `(com-backward-object ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :left #-mcclim :left-arrow))) + '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow))) (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table @@ -162,7 +162,7 @@ (set-key `(com-forward-word ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :right #-mcclim :right-arrow :control))) + '((#+(or mcclim building-mcclim) :right #-(or mcclim building-mcclim) :right-arrow :control))) (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table @@ -170,7 +170,7 @@ (set-key `(com-backward-word ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :left #-mcclim :left-arrow :control))) + '((#+(or mcclim building-mcclim) :left #-(or mcclim building-mcclim) :left-arrow :control))) (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table @@ -178,7 +178,7 @@ (set-key `(com-forward-line ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :down #-mcclim :down-arrow))) + '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow))) (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table @@ -186,7 +186,7 @@ (set-key `(com-backward-line ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :up #-mcclim :up-arrow))) + '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow))) (set-key 'com-beginning-of-line 'movement-table @@ -218,7 +218,7 @@ (set-key `(com-backward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :up #-mcclim :up-arrow :control))) + '((#+(or mcclim building-mcclim) :up #-(or mcclim building-mcclim) :up-arrow :control))) (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table @@ -226,7 +226,7 @@ (set-key `(com-forward-paragraph ,*numeric-argument-marker*) 'movement-table - '((#+mcclim :down #-mcclim :down-arrow :control))) + '((#+(or mcclim building-mcclim) :down #-(or mcclim building-mcclim) :down-arrow :control))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Thu Nov 16 19:22:38 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 16 Nov 2006 14:22:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061116192238.015A4762E5@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3986 Modified Files: buffer.lisp Log Message: Updated docstrings. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/08 01:15:33 1.1 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/16 19:22:38 1.2 @@ -31,7 +31,7 @@ (in-package :drei-buffer) (defclass buffer () () - (:documentation "A base class for all buffers. A buffer conceptually contains a + (:documentation "The base class for all buffers. A buffer conceptually contains a large array of arbitrary objects. Lines of objects are separated by newline characters. The last object of the buffer is not necessarily a newline character.")) @@ -47,31 +47,33 @@ (low-mark :reader low-mark) (high-mark :reader high-mark) (modified :initform nil :reader modified-p)) - (:documentation "The Drei standard buffer [an instantable subclass of buffer].")) + (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) (:documentation "Return the buffer that the mark is positioned in.")) (defclass mark () () - (:documentation "A base class for all marks.")) + (:documentation "The base class for all marks.")) (defclass left-sticky-mark (mark) () - (:documentation "A subclass of mark. A mark of this type will \"stick\" to the left of -an object, i.e. when an object is inserted at this mark, the mark will -be positioned to the left of the object")) + (:documentation "A subclass of mark. A mark of this type will +\"stick\" to the left of an object, i.e. when an object is +inserted at this mark, the mark will be positioned to the left of +the object.")) (defclass right-sticky-mark (mark) () - (:documentation "A subclass of mark. A mark of this type will \"stick\" to the right of -an object, i.e. when an object is inserted at this mark, the mark will -be positioned to the right of the object.")) + (:documentation "A subclass of mark. A mark of this type will +\"stick\" to the right of an object, i.e. when an object is +inserted at this mark, the mark will be positioned to the right +of the object.")) (defgeneric offset (mark) (:documentation "Return the offset of the mark into the buffer.")) (defgeneric (setf offset) (new-offset mark) - (:documentation "Set the offset of the mark into the buffer. A no-such-offset -condition is signaled if the offset is less than zero or greater than -the size of the buffer.")) + (:documentation "Set the offset of the mark into the buffer. A +no-such-offset condition is signaled if the offset is less than +zero or greater than the size of the buffer.")) (defclass mark-mixin () ((buffer :initarg :buffer :reader buffer) @@ -85,9 +87,9 @@ ((offset :reader condition-offset :initarg :offset)) (:report (lambda (condition stream) (format stream "No such offset: ~a" (condition-offset condition)))) - (:documentation "This condition is signaled whenever an attempt is -made to access buffer contents that is before the beginning or after -the end of the buffer.")) + (:documentation "This condition is signaled whenever an attempt +is made to access buffer contents that is before the beginning or +after the end of the buffer.")) (define-condition offset-before-beginning (no-such-offset) () @@ -186,10 +188,10 @@ (setf high-mark (make-instance 'standard-right-sticky-mark :buffer buffer)))) (defgeneric clone-mark (mark &optional stick-to) - (:documentation "Clone a mark. By default (when stick-to is NIL) -the same type of mark is returned. Otherwise stick-to is either :left -or :right indicating whether a left-sticky or a right-sticky mark -should be created.")) + (:documentation "Clone a mark. By default (when stick-to is +NIL) the same type of mark is returned. Otherwise stick-to is +either :left or :right indicating whether a left-sticky or a +right-sticky mark should be created.")) (defmethod clone-mark ((mark standard-left-sticky-mark) &optional stick-to) (cond ((or (null stick-to) (eq stick-to :left)) From crhodes at common-lisp.net Fri Nov 17 09:51:18 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 17 Nov 2006 04:51:18 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061117095118.BAA8E53000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv6416 Modified Files: dev-commands.lisp listener.lisp Log Message: Replace HACKISH-PRESENT with a view class mixin. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/04/10 21:24:53 1.35 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36 @@ -602,13 +602,13 @@ (with-ink (readers) (if readers (dolist (reader readers) - (hackish-present reader) + (present reader (presentation-type-of reader) :single-box t) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) - (hackish-present writer) + (present writer (presentation-type-of writer) :single-box t) (terpri)) (note "No writers")))))) @@ -1437,18 +1437,13 @@ ;;; Eval -(defun hackish-present (object) - "Hack of the day.. let McCLIM determine presentation type to use, except for lists, because the list presentation method is inappropriate for lisp return values." - (typecase object - (sequence (present object 'expression)) - (t (present object)))) - (defun display-evalues (values) (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) ((= 1 (length values)) - (hackish-present (first values)) + (present (first values) (presentation-type-of (first values)) + :single-box t) (fresh-line)) (t (do ((i 0 (1+ i)) (item values (rest item))) @@ -1456,7 +1451,8 @@ (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (hackish-present (first item)) + (present (first item) (presentation-type-of (first item)) + :single-box t) (fresh-line)))))) (defun shuffle-specials (form values) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/05/10 11:19:33 1.26 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27 @@ -150,7 +150,41 @@ (lambda () (funcall *listener-initial-function*) (fresh-line))))) - + +;;; Listener view +;;; +;;; FIXME: this TEXTUAL-VIEW thing is a lie: we can draw graphics. +;;; However, all the various presentation methods around the world are +;;; specialized on textual view, and it sucks to have to reimplement +;;; them all. +(defclass listener-view (textual-view) ()) + +(defclass listener-pointer-documentation-view + (listener-view pointer-documentation-view) + ()) + +(defparameter +listener-view+ (make-instance 'listener-view)) +(defparameter +listener-pointer-documentation-view+ + (make-instance 'listener-pointer-documentation-view)) + +(define-presentation-method present :around + ((object sequence) (type sequence) stream (view listener-view) + &key acceptably for-context-type) + (present object 'expression :stream stream :view view + :acceptably acceptably :for-context-type for-context-type)) + +(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)))) ;;; Listener application frame (define-application-frame listener (standard-application-frame @@ -213,7 +247,11 @@ (*read-default-float-format* *read-default-float-format*) (*read-eval* *read-eval*) (*read-suppress* *read-suppress*) - (*readtable* *readtable*)) + (*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) @@ -258,43 +296,52 @@ (let* ((command-table (find-command-table 'listener)) (*accelerator-gestures* (climi::compute-inherited-keystrokes command-table)) object type) - (handler-case - ;; Body - (with-input-editing (stream :input-sensitizer - (lambda (stream cont) - (if type - (with-output-as-presentation - (stream object type) - (funcall cont)) - (funcall cont)))) - (let ((c (read-gesture :stream stream :peek-p t))) - (setf object - (if (member c *form-opening-characters*) - (prog2 - (when (char= c #\,) - (read-gesture :stream stream)) ; lispm behavior - #| ---> |# (list 'com-eval (accept 'form :stream stream :prompt nil)) - (setf type 'command #|'form|# )) ; FIXME? - (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))))) + (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) + (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) @@ -303,14 +350,14 @@ 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 - :view (stream-default-view stream) - :stream stream) - object)))) + (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 + :view (stream-default-view stream) + :stream stream :single-box t) + object)))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) @@ -328,14 +375,14 @@ (process-name "Listener") (eval nil)) (flet ((run () - (run-frame-top-level - (make-application-frame 'listener - :width width - :height height - :system-command-reader system-command-reader) - :listener-funcall (cond ((null eval) nil) - ((functionp eval) eval) - (t (lambda () (eval eval))))))) + (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)))))))) (if new-process (clim-sys:make-process #'run :name process-name) (run)))) From crhodes at common-lisp.net Fri Nov 17 12:30:56 2006 From: crhodes at common-lisp.net (crhodes) Date: Fri, 17 Nov 2006 07:30:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061117123056.7E9DD3E008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv4741 Modified Files: dev-commands.lisp listener.lisp Log Message: A bit more prettiness: define a stream-present method to enforce :single-box t on listener-interactor streams; pass :single-box t explicitly to with-output-as-presentation, which is different. Make package prompts be presented as type 'package. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 09:51:18 1.36 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2006/11/17 12:30:56 1.37 @@ -106,7 +106,8 @@ (write-char #\( stream) (present arg 'symbol :stream stream) (write-char #\space stream) - (with-output-as-presentation (stream spec 'specializer) + (with-output-as-presentation (stream spec 'specializer + :single-box t) (if (typep spec 'class) (format stream "~S" (clim-mop:class-name spec)) (format stream "~S" `(eql ,(clim-mop:eql-specializer-object spec))))) @@ -476,7 +477,8 @@ :text-style text-style) ;; Present class name rather than class here because the printing of the ;; class object itself is rather long and freaks out the pointer doc pane. - (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name) + (with-output-as-presentation (stream (clim-mop:class-name class) 'class-name + :single-box t) ; (surrounding-output-with-border (stream :shape :drop-shadow) (princ (clim-mop:class-name class) stream)))) ;) inferior-fun @@ -567,7 +569,7 @@ (with-ink (,var) , at body) ))) (fcell (name :left) - (with-output-as-presentation (t slot 'slot-definition) + (with-output-as-presentation (t slot 'slot-definition :single-box t) (princ name)) (unless (eq type t) (fresh-line) @@ -602,13 +604,13 @@ (with-ink (readers) (if readers (dolist (reader readers) - (present reader (presentation-type-of reader) :single-box t) + (present reader (presentation-type-of reader)) (terpri)) (note "No readers~%"))) (with-ink (writers) (if writers (dolist (writer writers) - (present writer (presentation-type-of writer) :single-box t) + (present writer (presentation-type-of writer)) (terpri)) (note "No writers")))))) @@ -687,7 +689,7 @@ (invoke-as-heading (lambda () (format t "~&Slots for ") - (with-output-as-presentation (t (clim-mop:class-name class) 'class-name) + (with-output-as-presentation (t (clim-mop:class-name class) 'class-name :single-box t) (princ (clim-mop:class-name class))))) (present-the-slots class) )))))) @@ -916,7 +918,8 @@ do (progn (with-output-as-presentation (*standard-output* (clim-mop:class-name class) - 'class-name) + 'class-name + :single-box t) (format *standard-output* "~S~%" (clim-mop:class-name class))))))) (when methods @@ -1009,7 +1012,8 @@ normal-ink (make-rgb-color 0.4 0.4 0.4)) :text-style text-style) - (with-output-as-presentation (stream package 'package) + (with-output-as-presentation (stream package 'package + :single-box t) (format stream "~A (~D/~D)" (package-name package) internal external))))) inferior-fun :stream stream @@ -1061,7 +1065,8 @@ :version (pathname-version pathname)))))) (defun pretty-pretty-pathname (pathname stream &key (long-name t)) - (with-output-as-presentation (stream pathname 'clim:pathname) + (with-output-as-presentation (stream pathname 'clim:pathname + :single-box t) (let ((icon (icon-of pathname))) (when icon (draw-icon stream icon :extra-spacing 3))) (princ (pathname-printing-name pathname long-name) stream)) @@ -1135,7 +1140,7 @@ (format t " (only files of type ~a)" (pathname-type pathname))))) (when (parent-directory pathname) - (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname) + (with-output-as-presentation (t (strip-filespec (parent-directory pathname)) 'clim:pathname :single-box t) (draw-icon t (standard-icon "up-folder.xpm") :extra-spacing 3) (format t "Parent Directory~%"))) @@ -1441,19 +1446,23 @@ (with-drawing-options (t :ink +olivedrab+) (cond ((null values) (format t "No values.~%")) - ((= 1 (length values)) - (present (first values) (presentation-type-of (first values)) - :single-box t) + ((= 1 (length values)) + (let ((o (first values))) + (with-output-as-presentation (t o (presentation-type-of o) + :single-box t) + (present (first values) 'expression))) (fresh-line)) - (t (do ((i 0 (1+ i)) - (item values (rest item))) - ((null item)) + (t (do* ((i 0 (1+ i)) + (items values (rest items)) + (o (first items) (first items))) + ((null items)) (with-drawing-options (t :ink +limegreen+) (with-text-style (t (make-text-style nil :italic :small)) (format t "~A " i))) - (present (first item) (presentation-type-of (first item)) - :single-box t) - (fresh-line)))))) + (with-output-as-presentation (t o (presentation-type-of o) + :single-box t) + (present o 'expression)) + (fresh-line)))))) (defun shuffle-specials (form values) (setf +++ ++ @@ -1510,7 +1519,7 @@ (invoke-as-heading (lambda () (format t "Command table ") - (with-output-as-presentation (t ct 'clim:command-table) + (with-output-as-presentation (t ct 'clim:command-table :single-box t) (princ (command-table-name ct))))) (if commands (format-items commands :printer (lambda (cmd s) (present cmd 'clim:command-name :stream s)) --- /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 09:51:18 1.27 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/listener.lisp 2006/11/17 12:30:56 1.28 @@ -186,15 +186,35 @@ (values result type) (input-not-of-required-type result type)))) +;;; Listener interactor stream. If only STREAM-PRESENT were +;;; specializable on the VIEW argument, this wouldn't be necessary. +;;; However, it isn't, so we have to play this game. We currently +;;; only use this to get single-box presentation highlighting. + +(defclass listener-interactor-pane (interactor-pane) ()) + +(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) + ;; we would do this, but CLIM:PRESENT calls STREAM-PRESENT with all + ;; the keyword arguments explicitly. *sigh*. + #+nil + (if sbp + (call-next-method) + (apply #'call-next-method stream object type :single-box t args))) + ;;; Listener application frame (define-application-frame listener (standard-application-frame command-history-mixin) ((system-command-reader :accessor system-command-reader :initarg :system-command-reader :initform t)) - (:panes (interactor :interactor :scroll-bars t - :display-function #'listener-initial-display-function - :display-time 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)) (doc :pointer-documentation) (wholine (make-pane 'wholine-pane :display-function 'display-wholine :scroll-bars nil @@ -210,7 +230,7 @@ (:menu-bar t) (:layouts (default (vertically () - interactor + interactor-container doc wholine)))) @@ -298,16 +318,17 @@ object type) (flet ((sensitizer (stream cont) (case type - ((command) (with-output-as-presentation - (stream object type :single-box t) + ((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) - (presentation-type-of (cadr object)) - :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 @@ -354,15 +375,15 @@ (command ;; Kludge the cursor position - Goatee will have moved it all around (setf (stream-cursor-position stream) (values x y)) - (present object object-type - :view (stream-default-view stream) - :stream stream :single-box t) + (present object object-type :stream stream + :view (stream-default-view stream)) object)))) (defun print-listener-prompt (stream frame) (declare (ignore frame)) (with-text-face (stream :italic) - (print-package-name stream) + (with-output-as-presentation (stream *package* 'package :single-box t) + (print-package-name stream)) (princ "> " stream))) (defmethod frame-standard-output ((frame listener)) From thenriksen at common-lisp.net Fri Nov 17 20:18:56 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 17 Nov 2006 15:18:56 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061117201856.9E11E2E1BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27977/Drei Modified Files: input-editor.lisp drei.lisp drei-redisplay.lisp drei-clim.lisp Log Message: Drei redisplay cleanup. Fix some annoying bugs and make the structure of the redisplay functions clearer. Also minor fixup of the Drei-customized expression acceptor and some docstring changes. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/10 01:15:58 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/17 20:18:56 1.4 @@ -76,7 +76,7 @@ (syntax (buffer (drei-instance obj)))) ;; XXX Really add it here? (stream-add-output-record stream (drei-instance obj)) - (display-drei-area (drei-instance obj))))) + (display-drei (drei-instance obj))))) (defmethod stream-insertion-pointer ((stream drei-input-editing-mixin)) @@ -202,7 +202,7 @@ (delete-region begin-mark (stream-scan-pointer stream)) (insert-sequence begin-mark new-contents)) (update-syntax (buffer drei) (syntax (buffer drei))) - (display-drei-area drei) + (display-drei drei) (when (or rescan (not equal)) (queue-rescan stream))))) @@ -387,7 +387,7 @@ (when was-directly-processing (display-message "Aborted")))))) ;; Will also take care of redisplaying minibuffer. - (display-drei (pane-frame (editor-pane drei)) drei) + (display-drei drei) (let ((first-mismatch (mismatch before (stream-input-buffer stream)))) (cond ((null first-mismatch) ;; No change actually took place, even though IP may @@ -493,7 +493,7 @@ ;; Since everything inserted with this method is noise strings, we ;; do not bother to modify the scan pointer or queue rescans. (update-syntax (buffer drei) (syntax (buffer drei))) - (display-drei-area drei))) + (display-drei drei))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; @@ -591,12 +591,15 @@ for gesture = (with-input-context ('expression :override nil) (object type) (read-gesture :stream stream) - (expression (performing-drei-operations (drei :with-undo t) + (expression (performing-drei-operations (drei :with-undo t + :redisplay t) (presentation-replace-input stream object type (view drei) :buffer-start (stream-insertion-pointer stream) :allow-other-keys t - :accept-result nil)) + :accept-result nil + :rescan t)) + (rescan-if-necessary stream) nil)) ;; True if `gesture' was freshly read from the user, and not ;; just retrieved from the buffer during a rescan. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/14 07:48:30 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/17 20:18:56 1.6 @@ -535,7 +535,10 @@ :documentation "The kill ring object associated with the Drei instance.") (%previous-command :initform nil - :accessor previous-command) + :accessor previous-command + :documentation "The previous CLIM command +executed by this Drei instance. May be NIL if no command has been +executed.") (%point-cursor :accessor point-cursor :initarg :point-cursor :type cursor @@ -565,7 +568,7 @@ :initarg :minibuffer :type (or minibuffer-pane null) :documentation "The minibuffer pane (or null) -associated with the Drei instance.") +associated with the Drei instance. This may be NIL.") (%command-table :initform (make-instance 'drei-command-table :name 'drei-dispatching-table) :reader command-table @@ -575,8 +578,10 @@ looking up commands for the Drei instance. Has a sensible default, don't override it unless you know what you are doing.")) (:default-initargs :active t :editable-p t) - (:documentation "An abstract Drei class that should not be -directly instantiated.")) + (:documentation "The abstract Drei class that maintains +standard Drei editor state. It should not be directly +instantiated, a subclass implementing specific behavior (a Drei +variant) should be used instead.")) (defmethod (setf active) :after (new-val (drei drei)) (mapcar #'(lambda (cursor) @@ -616,7 +621,7 @@ bot (clone-mark (high-mark buffer) :right)))) ;; Main redisplay entry point. -(defgeneric display-drei (frame drei) +(defgeneric display-drei (drei) (:documentation "Display the given Drei instance.")) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; @@ -626,7 +631,9 @@ (defmacro handling-drei-conditions (&body body) "Evaluate `body' while handling Drei user notification signals. The handling consists of displaying their meaning to the -user in the minibuffer." +user in the minibuffer. This is the macro that ensures conditions +such as `motion-before-end' does not land the user in the +debugger." `(handler-case (progn , at body) (offset-before-beginning () (beep) (display-message "Beginning of buffer")) @@ -673,7 +680,9 @@ from `drei-instance'. The keyword arguments can be used to provide forms that will be used to obtain values for the respective special variables, instead of finding their value in -`drei-instance'." +`drei-instance'. This macro binds all of the usual Drei special +variables, but also some CLIM special variables needed for +ESA-style command parsing." (once-only (drei-instance) `(let* ((*current-buffer* ,(or current-buffer `(buffer ,drei-instance))) (*current-window* ,(or current-window drei-instance)) @@ -697,15 +706,17 @@ &key with-undo (update-syntax t) (redisplay t)) (with-accessors ((buffer buffer)) drei (with-undo ((when with-undo (list buffer))) - (funcall continuation) - (when update-syntax - (update-syntax buffer (syntax buffer)) - (when (modified-p buffer) - (clear-modify buffer))) - (when redisplay - (display-drei *application-frame* drei)) - (unless with-undo - (clear-undo-history (buffer drei)))))) + (funcall continuation)) + (when (or update-syntax redisplay) + (update-syntax buffer (syntax buffer))) + (unless with-undo + (clear-undo-history (buffer drei))) + (when redisplay + (etypecase drei + (pane + (redisplay-frame-pane *application-frame* drei)) + (t + (display-drei drei)))))) (defmacro performing-drei-operations ((drei &rest args &key with-undo (update-syntax t) @@ -718,7 +729,8 @@ redisplayed, the syntax updated, etc. Exactly what is done can be controlled via the keyword arguments. Note that if `with-undo' is false, the *entire* undo history will be cleared after `body' has -been evaluated." +been evaluated. This macro expands into a call to +`invoke-performing-drei-operations'." (declare (ignore with-undo update-syntax redisplay)) `(invoke-performing-drei-operations ,drei (lambda () , at body) @@ -772,7 +784,8 @@ can be done to arbitrary streams from within `body'. Or, at least, make sure the Drei instance will not be a problem. When Drei calls a command, it will be wrapped in this macro, so it -should be safe to use `accept' within Drei commands." +should be safe to use `accept' within Drei commands. This macro +expands into a call to `invoke-accepting-from-user'." `(invoke-accepting-from-user ,drei #'(lambda () , at body))) ;;; Plain `execute-frame-command' is not good enough for us. Our @@ -780,29 +793,19 @@ ;;; that it is also responsible for updating the syntax of the buffer ;;; in the pane. (defgeneric execute-drei-command (drei-instance command) - (:documentation "Execute a CLIM command for a given Drei -instance. Methods defined on this generic function should set up -things like handling some Drei conditions, setting up undo, -etc.")) - -(defun execute-drei-command-for-frame (frame drei-instance command) - "Execute `command' using `execute-frame-command' on -`frame'. This function will handle Drei conditions and display -them on the minibuffer, as well as recording whatever changes -`command' makes to the buffer in the undo tree, and update the -syntax to reflect the changes." - (with-accessors ((buffer buffer)) drei-instance - (handling-drei-conditions - ;; Must be a list of buffers, so wrap in call to `list'. - (with-undo ((list buffer)) - (accepting-from-user (drei-instance) - (execute-frame-command frame command))) - (setf (previous-command drei-instance) command) - (update-syntax buffer (syntax buffer)) - (when (modified-p buffer) - (clear-modify buffer))))) + (:documentation "Execute `command' for `drei'. This is the +standard function for executing Drei commands - it will take care +of reporting to the user if a condition is signalled, updating +the syntax, setting the `previous-command' of `drei' and +recording the operations performed by `command' for undo.")) (defmethod execute-drei-command ((drei drei) command) - (let ((*standard-input* (or *minibuffer* *standard-input*))) - (execute-drei-command-for-frame (pane-frame (editor-pane drei)) - drei command))) + (with-accessors ((buffer buffer)) drei + (let ((*standard-input* (or *minibuffer* *standard-input*))) + (performing-drei-operations (drei :redisplay nil + :update-syntax t + :with-undo t) + (handling-drei-conditions + (accepting-from-user (drei) + (apply (command-name command) (command-arguments command))) + (setf (previous-command drei) command)))))) --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/09 00:52:01 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2006/11/17 20:18:56 1.4 @@ -394,27 +394,14 @@ (round (- cursor-x))) 0))))))) -(defun display-drei-gadget (drei &key force-p (display-minibuffer t)) - "Redisplay the given Drei pane. If `display-minibuffer' is -non-NIL (the default), also redisplay the minibuffer associated -with the Drei instance. Use this from the event handlers so -`*standard-output*' is properly bound." - (let ((*standard-output* drei)) - (redisplay-frame-pane (pane-frame drei) drei :force-p force-p)) - (when display-minibuffer - (with-accessors ((minibuffer minibuffer)) drei - (let* ((minibuffer (or minibuffer *minibuffer*)) - (*standard-output* minibuffer)) - (redisplay-frame-pane (pane-frame minibuffer) minibuffer))))) - (defmethod handle-repaint :before ((pane drei-pane) region) (declare (ignore region)) (redisplay-frame-pane (pane-frame pane) pane)) -(defun display-drei-pane (drei-pane current-p) +(defun display-drei-pane (frame drei-pane) "Display `pane'. If `pane' has focus, `current-p' should be non-NIL." - (declare (ignore current-p)) + (declare (ignore frame)) (with-accessors ((buffer buffer) (top top) (bot bot) (point-cursor point-cursor)) drei-pane (if (full-redisplay-p drei-pane) --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/14 07:48:30 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/17 20:18:56 1.7 @@ -150,7 +150,7 @@ :end-of-line-action :scroll :background *background-color* :foreground *foreground-color* - :display-function 'display-drei + :display-function 'display-drei-pane :default-view +drei-textual-view+ :width 900 :active nil) @@ -158,6 +158,9 @@ permits (and requires) the host application to control the command loop completely.")) +(defmethod display-drei ((drei drei-pane)) + (redisplay-frame-pane (pane-frame drei) drei)) + (defmethod editor-pane ((drei drei-pane)) ;; The whole point of the `drei-pane' class is that it's its own ;; display surface. @@ -241,12 +244,12 @@ (defmethod armed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) t) - (display-drei-gadget gadget :display-minibuffer nil)) + (display-drei gadget)) (defmethod disarmed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) (setf (active gadget) nil) - (display-drei-gadget gadget :display-minibuffer nil)) + (display-drei gadget)) (defun handle-new-gesture (drei gesture) (let ((*command-processor* drei) @@ -259,8 +262,24 @@ (unbound-gesture-sequence (c) (display-message "~A is unbound" (gesture-name (gestures c)))) (abort-gesture () - (display-message "Aborted"))) - (redisplay-frame-pane (pane-frame drei) drei)))) + (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)))) + +(defmethod execute-drei-command :after ((drei drei-gadget-pane) command) + (with-accessors ((buffer buffer)) drei + (when (syntax buffer) + (update-syntax buffer (syntax buffer))) + (when (modified-p buffer) + (setf (needs-saving buffer) t)))) ;;; This is the method that functions as the entry point for all Drei ;;; gadget logic. @@ -280,14 +299,7 @@ (unwind-protect (progn (deactivate-gadget drei) (funcall continuation)) (activate-gadget drei) - ;; XXX: Work around McCLIM brokenness: - #+(or mcclim building-mcclim) (climi::arm-gadget drei t))) - -(defmethod execute-drei-command ((drei drei-gadget-pane) command) - (let* ((*minibuffer* (or *minibuffer* - (unless (eq drei *standard-input*) - *standard-input*)))) - (execute-drei-command-for-frame (pane-frame drei) drei command))) + (setf (active drei) t))) (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) @@ -314,6 +326,9 @@ &key) (tree-recompute-extent area)) +(defmethod display-drei ((drei drei-area)) + (display-drei-area drei)) + ;; For areas, we need to switch to ESA abort gestures after we have ;; left the CLIM gesture reading machinery, but before we start doing ;; ESA gesture processing. @@ -343,18 +358,11 @@ (:documentation "A constellation of a Drei gadget instance and a minibuffer.")) -(defmethod display-drei (frame (drei drei-pane)) - (declare (ignore frame)) - (display-drei-pane drei (active drei))) - -(defmethod display-drei :after (frame (drei drei)) +(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)))) -(defmethod display-drei (frame (drei drei-area)) - (display-drei-area drei)) - ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Programmer interface stuff From thenriksen at common-lisp.net Fri Nov 17 20:33:24 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 17 Nov 2006 15:33:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061117203324.61EBC36002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30700 Modified Files: graphics.lisp Log Message: Remove initial space in docstring as it confuses my docstring extractor. --- /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/10/14 18:38:12 1.54 +++ /project/mcclim/cvsroot/mcclim/graphics.lisp 2006/11/17 20:33:24 1.55 @@ -528,9 +528,10 @@ toward-x toward-y transform-glyphs ink clipping-region transformation text-style text-family text-face text-size) -" Draws a single character of filled text represented by the given element. - element is a character or other object to be translated into a font index. - The given x and y specify the left baseline position for the character." +"Draws a single character of filled text represented by the given +element. element is a character or other object to be translated +into a font index. The given x and y specify the left baseline +position for the character." (declare (ignore ink clipping-region transformation text-style text-family text-face text-size)) (with-medium-options (sheet args) From thenriksen at common-lisp.net Sat Nov 18 15:42:43 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 10:42:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061118154243.CC8F028068@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv3308 Modified Files: buffer.lisp Log Message: More docstring fixes and additions. --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/16 19:22:38 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/18 15:42:43 1.3 @@ -31,22 +31,31 @@ (in-package :drei-buffer) (defclass buffer () () - (:documentation "The base class for all buffers. A buffer conceptually contains a -large array of arbitrary objects. Lines of objects are separated by -newline characters. The last object of the buffer is not -necessarily a newline character.")) - -(defgeneric low-mark (buffer)) - -(defgeneric high-mark (buffer)) - -(defgeneric modified-p (buffer)) + (:documentation "The base class for all buffers. A buffer +conceptually contains a large array of arbitrary objects. Lines +of objects are separated by newline characters. The last object +of the buffer is not necessarily a newline character.")) + +(defgeneric low-mark (buffer) + (:documentation "Return the low mark of the buffer.")) + +(defgeneric high-mark (buffer) + (:documentation "Return the high mark of the buffer.")) + +(defgeneric modified-p (buffer) + (:documentation "Return true if and only if the buffer has been +modified.")) (defclass standard-buffer (buffer) ((contents :initform (make-instance 'standard-cursorchain)) - (low-mark :reader low-mark) - (high-mark :reader high-mark) - (modified :initform nil :reader modified-p)) + (low-mark :reader low-mark + :documentation "The low mark of the buffer.") + (high-mark :reader high-mark + :documentation "The high mark of the buffer.") + (modified :initform nil + :reader modified-p + :documentation "True if and only if the buffer has +been modified.")) (:documentation "The standard instantiable class for buffers.")) (defgeneric buffer (mark) @@ -72,11 +81,14 @@ (defgeneric (setf offset) (new-offset mark) (:documentation "Set the offset of the mark into the buffer. A -no-such-offset condition is signaled if the offset is less than -zero or greater than the size of the buffer.")) +motion-before-beginning condition is signaled if the offset is +less than zero. A motion-after-end condition is signaled if the +offset is greater than the size of the buffer.")) (defclass mark-mixin () - ((buffer :initarg :buffer :reader buffer) + ((buffer :initarg :buffer + :reader buffer + :documentation "The buffer that the mark is in.") (cursor :reader cursor)) (:documentation "A mixin class used in the initialization of a mark.")) @@ -135,12 +147,26 @@ (setf (cursor-pos (cursor mark)) new-offset)) (defgeneric backward-object (mark &optional count) - (:documentation "Move `mark' `count' objects backwards. Returns - `mark'.")) + (:documentation "Move the mark backward the number of positions +indicated by count. This function could be implemented by a +`decf' on the offset of the mark, but many buffer implementations +can implement this function much more efficiently in a different +way. A `motion-before-beginning' condition is signaled if the +resulting offset of the mark is less than zero. A +motion-after-end condition is signaled if the resulting offset of +the mark is greater than the size of the buffer. Returns +`mark'.")) (defgeneric forward-object (mark &optional count) - (:documentation "Move `mark' `count' objects forwards. Returns - `mark'")) + (:documentation "Move the mark forward the number of positions +indicated by count. This function could be implemented by an +`incf' on the offset of the mark, but many buffer implementations +can implement this function much more efficiently in a different +way. A `motion-before-beginning' condition is signaled if the +resulting offset of the mark is less than zero. A +`motion-after-end' condition is signaled if the resulting offset +of the mark is greater than the size of the buffer. Returns +`mark'.")) (defmethod forward-object ((mark mark-mixin) &optional (count 1)) (incf (offset mark) count) @@ -226,10 +252,10 @@ count (eql (buffer-object buffer offset) #\Newline))) (defgeneric mark< (mark1 mark2) - (:documentation "Return t if the offset of mark1 is strictly less than that of mark2. -An error is signaled if the two marks are not positioned in the same -buffer. It is acceptable to pass an offset in place of one of the -marks")) + (:documentation "Return T if the offset of `mark1' is strictly +less than that of `mark2'. An error is signaled if the two marks +are not positioned in the same buffer. It is acceptable to pass +an offset in place of one of the marks.")) (defmethod mark< ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -242,10 +268,10 @@ (< mark1 (offset mark2))) (defgeneric mark<= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is less than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is less than +or equal to that of `mark2'. An error is signaled if the two +marks are not positioned in the same buffer. It is acceptable to +pass an offset in place of one of the marks.")) (defmethod mark<= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -258,9 +284,10 @@ (<= mark1 (offset mark2))) (defgeneric mark= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is equal to that of mark2. An error - is signaled if the two marks are not positioned in the same buffer. - It is acceptable to pass an offset in place of one of the marks.")) + (:documentation "Return T if the offset of `mark1' is equal to +that of `mark2'. An error is signaled if the two marks are not +positioned in the same buffer. It is acceptable to pass an +offset in place of one of the marks.")) (defmethod mark= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -273,10 +300,10 @@ (= mark1 (offset mark2))) (defgeneric mark> (mark1 mark2) - (:documentation "Return t if the offset of mark1 is strictly greater than that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is strictly +greater than that of `mark2'. An error is signaled if the two +marks are not positioned in the same buffer. It is acceptable to +pass an offset in place of one of the marks.")) (defmethod mark> ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -289,10 +316,10 @@ (> mark1 (offset mark2))) (defgeneric mark>= (mark1 mark2) - (:documentation "Return t if the offset of mark1 is greater than or equal to that of -mark2. An error is signaled if the two marks are not positioned in -the same buffer. It is acceptable to pass an offset in place of one -of the marks.")) + (:documentation "Return T if the offset of `mark1' is greater +than or equal to that of `mark2'. An error is signaled if the +two marks are not positioned in the same buffer. It is +acceptable to pass an offset in place of one of the marks.")) (defmethod mark>= ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -306,8 +333,8 @@ (defgeneric beginning-of-buffer (mark) (:documentation "Move the mark to the beginning of the buffer. - This is equivalent to (setf (offset mark) 0), but returns - mark.")) +This is equivalent to `(setf (offset mark) 0)', but returns +mark.")) ;; Easy way to make sure mark is always returned. (defmethod beginning-of-buffer :around (mark) @@ -319,7 +346,7 @@ (defgeneric end-of-buffer (mark) (:documentation "Move the mark to the end of the buffer and - return mark.")) +return mark.")) (defmethod end-of-buffer :around (mark) (call-next-method) @@ -329,41 +356,44 @@ (setf (offset mark) (size (buffer mark)))) (defgeneric beginning-of-buffer-p (mark) - (:documentation "Return t if the mark is at the beginning of - the buffer, nil otherwise.")) + (:documentation "Return T if the mark is at the beginning of +the buffer, nil otherwise.")) (defmethod beginning-of-buffer-p ((mark mark-mixin)) (zerop (offset mark))) (defgeneric end-of-buffer-p (mark) - (:documentation "Return t if the mark is at the end of the buffer, nil otherwise.")) + (:documentation "Return T if the mark is at the end of the +buffer, NIL otherwise.")) (defmethod end-of-buffer-p ((mark mark-mixin)) (= (offset mark) (size (buffer mark)))) (defgeneric beginning-of-line-p (mark) - (:documentation "Return t if the mark is at the beginning of the line (i.e., if the -character preceding the mark is a newline character or if the mark is -at the beginning of the buffer), nil otherwise.")) + (:documentation "Return T if the mark is at the beginning of +the line (i.e., if the character preceding the mark is a newline +character or if the mark is at the beginning of the buffer), NIL +otherwise.")) (defmethod beginning-of-line-p ((mark mark-mixin)) (or (beginning-of-buffer-p mark) (eql (object-before mark) #\Newline))) (defgeneric end-of-line-p (mark) - (:documentation "Return t if the mark is at the end of the line (i.e., if the character -following the mark is a newline character, or if the mark is at the -end of the buffer), nil otherwise.")) + (:documentation "Return T if the mark is at the end of the +line (i.e., if the character following the mark is a newline +character, or if the mark is at the end of the buffer), NIL +otherwise.")) (defmethod end-of-line-p ((mark mark-mixin)) (or (end-of-buffer-p mark) (eql (object-after mark) #\Newline))) (defgeneric beginning-of-line (mark) - (:documentation "Move the mark to the beginning of the line. The mark will be - positioned either immediately after the closest preceding newline - character, or at the beginning of the buffer if no preceding newline - character exists. Returns mark.")) + (:documentation "Move the mark to the beginning of the line. +The mark will be positioned either immediately after the closest +receding newline character, or at the beginning of the buffer if +no preceding newline character exists. Returns `mark'.")) (defmethod beginning-of-line :around (mark) (call-next-method) @@ -374,9 +404,10 @@ do (backward-object mark))) (defgeneric end-of-line (mark) - (:documentation "Move the mark to the end of the line. The mark will be positioned -either immediately before the closest following newline character, or -at the end of the buffer if no following newline character exists. Returns mark.")) + (:documentation "Move the mark to the end of the line. The mark +will be positioned either immediately before the closest +following newline character, or at the end of the buffer if no +following newline character exists. Returns `mark'.")) (defmethod end-of-line :around (mark) (call-next-method) @@ -393,17 +424,18 @@ (setf (offset mark) offset))) (defgeneric buffer-line-number (buffer offset) - (:documentation "Return the line number of the offset. Lines are numbered from zero.")) + (:documentation "Return the line number of the offset. Lines +are numbered from zero.")) (defmethod buffer-line-number ((buffer standard-buffer) (offset integer)) (loop for i from 0 below offset count (eql (buffer-object buffer i) #\Newline))) (defgeneric buffer-column-number (buffer offset) - (:documentation "Return the column number of the offset. The column number of an offset is - the number of objects between it and the preceding newline, or - between it and the beginning of the buffer if the offset is on the - first line of the buffer.")) + (:documentation "Return the column number of the offset. The +column number of an offset is the number of objects between it +and the preceding newline, or between it and the beginning of the +buffer if the offset is on the first line of the buffer.")) (defmethod buffer-column-number ((buffer standard-buffer) (offset integer)) (loop for i downfrom offset @@ -412,16 +444,17 @@ count t)) (defgeneric line-number (mark) - (:documentation "Return the line number of the mark. Lines are numbered from zero.")) + (:documentation "Return the line number of the mark. Lines are +numbered from zero.")) (defmethod line-number ((mark mark-mixin)) (buffer-line-number (buffer mark) (offset mark))) (defgeneric column-number (mark) - (:documentation "Return the column number of the mark. The column number of a mark is - the number of objects between it and the preceding newline, or - between it and the beginning of the buffer if the mark is on the - first line of the buffer.")) + (:documentation "Return the column number of the mark. The +column number of a mark is the number of objects between it and +the preceding newline, or between it and the beginning of the +buffer if the mark is on the first line of the buffer.")) (defmethod column-number ((mark mark-mixin)) (buffer-column-number (buffer mark) (offset mark))) @@ -440,10 +473,11 @@ finally (return (column-number mark)))) (defgeneric insert-buffer-object (buffer offset object) - (:documentation "Insert the object at the offset in the buffer. Any left-sticky marks - that are placed at the offset will remain positioned before the - inserted object. Any right-sticky marks that are placed at the - offset will be positioned after the inserted object.")) + (:documentation "Insert the object at the offset in the buffer. +Any left-sticky marks that are placed at the offset will remain +positioned before the inserted object. Any right-sticky marks +that are placed at the offset will be positioned after the +inserted object.")) (defmethod insert-buffer-object ((buffer standard-buffer) offset object) (assert (<= 0 offset) () @@ -453,31 +487,33 @@ (insert* (slot-value buffer 'contents) offset object)) (defgeneric insert-buffer-sequence (buffer offset sequence) - (:documentation "Like calling insert-buffer-object on each of the objects in the -sequence.")) + (:documentation "Like calling insert-buffer-object on each of +the objects in the sequence.")) (defmethod insert-buffer-sequence ((buffer standard-buffer) offset sequence) (insert-vector* (slot-value buffer 'contents) offset sequence)) (defgeneric insert-object (mark object) - (:documentation "Insert the object at the mark. This function simply calls -insert-buffer-object with the buffer and the position of the mark.")) + (:documentation "Insert the object at the mark. This function +simply calls insert-buffer-object with the buffer and the +position of the mark.")) (defmethod insert-object ((mark mark-mixin) object) (insert-buffer-object (buffer mark) (offset mark) object)) (defgeneric insert-sequence (mark sequence) - (:documentation "Insert the objects in the sequence at the mark. This function simply -calls insert-buffer-sequence with the buffer and the position of the -mark.")) + (:documentation "Insert the objects in the sequence at the +mark. This function simply calls insert-buffer-sequence with the +buffer and the position of the mark.")) (defmethod insert-sequence ((mark mark-mixin) sequence) (insert-buffer-sequence (buffer mark) (offset mark) sequence)) (defgeneric delete-buffer-range (buffer offset n) - (:documentation "Delete n objects from the buffer starting at the offset. If offset - is negative or offset+n is greater than the size of the buffer, a - no-such-offset condition is signaled.")) + (:documentation "Delete n objects from the buffer starting at +the offset. If `offset' is negative or `offset'+`n' is greater +than the size of the buffer, a `no-such-offset' condition is +signaled.")) (defmethod delete-buffer-range ((buffer standard-buffer) offset n) (assert (<= 0 offset) () @@ -488,9 +524,9 @@ do (delete* (slot-value buffer 'contents) offset))) (defgeneric delete-range (mark &optional n) - (:documentation "Delete n objects after (if n > 0) or before (if n < 0) the mark. -This function eventually calls delete-buffer-range, provided that n -is not zero.")) + (:documentation "Delete `n' objects after `(if n > 0)' or +before `(if n < 0)' the mark. This function eventually calls +delete-buffer-range, provided that `n' is not zero.")) (defmethod delete-range ((mark mark-mixin) &optional (n 1)) (cond ((plusp n) (delete-buffer-range (buffer mark) (offset mark) n)) @@ -499,9 +535,10 @@ (defgeneric delete-region (mark1 mark2) (:documentation "Delete the objects in the buffer that are -between mark1 and mark2. An error is signaled if the two marks -are positioned in different buffers. It is acceptable to pass an -offset in place of one of the marks.")) +between `mark1' and `mark2'. An error is signaled if the two +marks are positioned in different buffers. It is acceptable to +pass an offset in place of one of the marks. This function calls +`delete-buffer-range' with the appropriate arguments.")) (defmethod delete-region ((mark1 mark-mixin) (mark2 mark-mixin)) (assert (eq (buffer mark1) (buffer mark2))) @@ -524,9 +561,10 @@ (delete-buffer-range (buffer mark2) offset1 (- offset2 offset1)))) (defgeneric buffer-object (buffer offset) [103 lines skipped] From thenriksen at common-lisp.net Sat Nov 18 20:47:47 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 15:47:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061118204747.0FA2971108@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv22662 Modified Files: esa.lisp Log Message: Calling `window-clear' here means that sometimes repeated calls to `display-message' will clear each other, which is bummer. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/08 01:10:16 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/18 20:47:46 1.2 @@ -301,7 +301,6 @@ (funcall continuation minibuffer)))) (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation) - (window-clear minibuffer) (funcall continuation minibuffer)) (defmethod invoke-with-minibuffer-stream ((minibuffer null) continuation) From thenriksen at common-lisp.net Sat Nov 18 20:52:53 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 15:52:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061118205253.48174100D@common-lisp.net> 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))) From thenriksen at common-lisp.net Sat Nov 18 20:59:28 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 15:59:28 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061118205928.5EAB0404D@common-lisp.net> 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))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Sat Nov 18 21:01:47 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 16:01:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061118210147.2B9BA19018@common-lisp.net> 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"))) From thenriksen at common-lisp.net Sat Nov 18 22:02:43 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 18 Nov 2006 17:02:43 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061118220243.033C74D009@common-lisp.net> 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) From thenriksen at common-lisp.net Sun Nov 19 11:39:45 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 19 Nov 2006 06:39:45 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061119113945.A0EFC210B5@common-lisp.net> 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.")) From crhodes at common-lisp.net Sun Nov 19 15:31:44 2006 From: crhodes at common-lisp.net (crhodes) Date: Sun, 19 Nov 2006 10:31:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061119153144.52C1054126@common-lisp.net> 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. From dlichteblau at common-lisp.net Sun Nov 19 15:55:12 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 10:55:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061119155512.08FA85B005@common-lisp.net> 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 - , at argtypes)) + (if (and (eq rtype 'cairo_status_t) + (not (equal name "cairo_status"))) + `(def-cairo-fun ,name ,rtype , at argtypes) + `(cffi:defcfun (,name ,(intern (string-upcase name) :clim-gtkairo)) + ,rtype + , at argtypes))) + +(defmacro defcenum (name &rest values) + `(progn + (cffi:defcenum ,name , at 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] From dlichteblau at common-lisp.net Sun Nov 19 15:55:34 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 10:55:34 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061119155534.F3C455B062@common-lisp.net> 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") From dlichteblau at common-lisp.net Sun Nov 19 17:31:20 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 12:31:20 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061119173120.B6DCE2201A@common-lisp.net> 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 From dlichteblau at common-lisp.net Sun Nov 19 17:32:11 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 12:32:11 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061119173211.795E62201B@common-lisp.net> 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: From dlichteblau at common-lisp.net Sun Nov 19 18:08:17 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 13:08:17 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061119180817.2F0C236009@common-lisp.net> 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 From thenriksen at common-lisp.net Mon Nov 20 09:00:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 20 Nov 2006 04:00:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061120090058.96F0239024@common-lisp.net> 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) , at 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) From dlichteblau at common-lisp.net Sun Nov 19 17:21:48 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 12:21:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061119172148.4A628210C0@common-lisp.net> 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] From dlichteblau at common-lisp.net Sun Nov 19 18:09:07 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 19 Nov 2006 13:09:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061119180907.40ED036009@common-lisp.net> 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: From dlichteblau at common-lisp.net Mon Nov 20 19:53:44 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Mon, 20 Nov 2006 14:53:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061120195344.C337A1C008@common-lisp.net> 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? From ahefner at common-lisp.net Tue Nov 21 20:34:40 2006 From: ahefner at common-lisp.net (ahefner) Date: Tue, 21 Nov 2006 15:34:40 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061121203440.5E8651A0A8@common-lisp.net> 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) From ahefner at common-lisp.net Tue Nov 21 22:39:32 2006 From: ahefner at common-lisp.net (ahefner) Date: Tue, 21 Nov 2006 17:39:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061121223932.6DCD25B077@common-lisp.net> 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)))) From ahefner at common-lisp.net Tue Nov 21 22:59:12 2006 From: ahefner at common-lisp.net (ahefner) Date: Tue, 21 Nov 2006 17:59:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20061121225912.61C2C72092@common-lisp.net> 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*) From thenriksen at common-lisp.net Tue Nov 21 23:28:07 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 21 Nov 2006 18:28:07 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061121232807.E0AB524069@common-lisp.net> 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))) From ahefner at common-lisp.net Tue Nov 21 23:57:59 2006 From: ahefner at common-lisp.net (ahefner) Date: Tue, 21 Nov 2006 18:57:59 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20061121235759.921A46D02A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv19610 Modified Files: goatee-command.lisp Log Message: Change remaining #\Delete characters to #\Rubout. --- /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/11/21 22:59:12 1.23 +++ /project/mcclim/cvsroot/mcclim/Goatee/goatee-command.lisp 2006/11/21 23:57:59 1.24 @@ -333,10 +333,10 @@ (add-gesture-command-to-table '(#\d :meta) 'delete-word *simple-area-gesture-table*) -(add-gesture-command-to-table '(#\delete :meta) +(add-gesture-command-to-table '(#\rubout :meta) 'delete-word *simple-area-gesture-table*) -(add-gesture-command-to-table '(#\delete :control) +(add-gesture-command-to-table '(#\rubout :control) 'delete-word *simple-area-gesture-table*) From ahefner at common-lisp.net Wed Nov 22 06:26:49 2006 From: ahefner at common-lisp.net (ahefner) Date: Wed, 22 Nov 2006 01:26:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061122062649.5CEF42B211@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv22089 Modified Files: recording.lisp Log Message: Add checking for several cases where recompute-extent-for-changed-child can avoid calling %tree-recompute-extent, and one case where it must do so. Added copious comments explaining my reasoning, in hopes that it will prevent these from getting commented out again in the future (or to help fix them if I've made a mistake). --- /project/mcclim/cvsroot/mcclim/recording.lisp 2006/06/13 02:26:46 1.128 +++ /project/mcclim/cvsroot/mcclim/recording.lisp 2006/11/22 06:26:48 1.129 @@ -670,16 +670,23 @@ (output-record-children record))) ;;; XXX Dunno about this definition... -- moore +;;; Your apprehension is justified, but we lack a better means by which +;;; to distinguish "empty" compound records (roots of trees of compound +;;; records, containing no non-compound records). Such subtrees should +;;; not affect bounding rectangles. -- Hefner (defun null-bounding-rectangle-p (bbox) (with-bounding-rectangle* (x1 y1 x2 y2) bbox (and (zerop x1) (zerop y1) - (zerop x2) (zerop y2)))) + (zerop x2) (zerop y2)))) ;;; 16.2.3. Output Record Change Notification Protocol (defmethod recompute-extent-for-new-child ((record compound-output-record) child) (unless (null-bounding-rectangle-p child) (with-bounding-rectangle* (old-x1 old-y1 old-x2 old-y2) record + ;; I expect there's a bug here. If you create a record A, add an empty child B + ;; then add a displayed-output-record C, the code below will use min/max to + ;; grow the all-zero bounds of A, typically giving a bogus x1,y1 of 0,0. --Hefner (if (eql 1 (output-record-count record)) (setf (rectangle-edges* record) (bounding-rectangle* child)) (with-bounding-rectangle* (x1-child y1-child x2-child y2-child) @@ -765,21 +772,41 @@ ;; If so, we can use min/max to grow record's current rectangle. ;; If not, the child has shrunk, and we need to fully recompute. (multiple-value-bind (nx1 ny1 nx2 ny2) - (cond ((not (output-record-parent changed-child)) - ;; The child has been deleted; who knows what the - ;; new bounding box might be. - (%tree-recompute-extent* record)) - ((eql (output-record-count record) 1) - (values cx1 cy1 cx2 cy2)) - #+nil((null-bounding-rectangle-p record) - (%tree-recompute-extent* record)) - #+nil((null-bounding-rectangle-p changed-child) - (values ox1 oy1 ox2 oy2)) - ((and (<= cx1 old-min-x) (<= cy1 old-min-y) - (>= cx2 old-max-x) (>= cy2 old-max-y)) - (values (min cx1 ox1) (min cy1 oy1) - (max cx2 ox2) (max cy2 oy2))) - (t (%tree-recompute-extent* record))) + (cond + ;; The child has been deleted; who knows what the + ;; new bounding box might be. + ((not (output-record-parent changed-child)) + (%tree-recompute-extent* record)) + ;; Only one child of record, and we already have the bounds. + ((eql (output-record-count record) 1) + (values cx1 cy1 cx2 cy2)) + ;; If our record occupied no space (had no children, or had only + ;; children similarly occupying no space, hackishly determined by + ;; null-bounding-rectangle-p), recompute the extent now, otherwise + ;; the next COND clause would, as an optimization, attempt to extend + ;; our current bounding rectangle, which is invalid. + ((null-bounding-rectangle-p record) + (%tree-recompute-extent* record)) + ;; In the following cases, we can grow the new bounding rectangle + ;; from its previous state: + ((or + ;; If the child was originally empty, it should not have affected + ;; previous computation of our bounding rectangle. + ;; This is hackish for reasons similar to the above. + (and (zerop old-min-x) (zerop old-min-y) + (zerop old-max-x) (zerop old-max-y)) + ;; New child bounds contain old child bounds, so use min/max + ;; to extend the already-calculated rectangle. + (and (<= cx1 old-min-x) (<= cy1 old-min-y) + (>= cx2 old-max-x) (>= cy2 old-max-y))) + (values (min cx1 ox1) (min cy1 oy1) + (max cx2 ox2) (max cy2 oy2))) + ;; No shortcuts - we must compute a new bounding box from those of + ;; all our children. We want to avoid this - in worst cases, such as + ;; a toplevel output history, large graph, or table, there may exist + ;; thousands of children. Without the above optimizations, + ;; construction becomes O(N^2) due to bounding rectangle calculation. + (t (%tree-recompute-extent* record))) ;; XXX banish x, y (with-slots (x y) record @@ -864,7 +891,6 @@ for child across children do (funcall function child)))) - (defmethod map-over-output-records-containing-position (function (record standard-sequence-output-record) x y &optional (x-offset 0) (y-offset 0) From thenriksen at common-lisp.net Wed Nov 22 13:50:44 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 08:50:44 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061122135044.6D0125000D@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26849/Drei Modified Files: lisp-syntax.lisp Log Message: Fixed bit-vectors. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/21 23:28:07 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/22 13:50:44 1.6 @@ -384,7 +384,7 @@ (defclass structure-start-lexeme (lisp-lexeme) ()) (defclass pathname-start-lexeme (lisp-lexeme) ()) (defclass undefined-reader-macro-lexeme (lisp-lexeme) ()) -(defclass bit-vector-lexeme (form-lexeme) ()) +(defclass bit-vector-form (form-lexeme complete-form-mixin) ()) (defclass number-lexeme (form-lexeme complete-form-mixin) ()) (defclass token-mixin () ()) (defclass literal-object-lexeme (form-lexeme) ()) @@ -475,7 +475,7 @@ (if (and (not (end-of-buffer-p scan)) (constituentp (object-after scan))) (make-instance 'error-lexeme) - (make-instance 'bit-vector-lexeme))) + (make-instance 'bit-vector-form))) (#\: (fo) (make-instance 'uninterned-symbol-lexeme)) (#\. (fo) @@ -2636,6 +2636,10 @@ (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))) +(defmethod token-to-object ((syntax lisp-syntax) (token bit-vector-form) + &key &allow-other-keys) + (read-from-string (token-string syntax token))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Arglist fetching. From thenriksen at common-lisp.net Wed Nov 22 14:15:52 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:15:52 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20061122141552.E0C9C5B068@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv30056/Goatee Modified Files: editing-stream.lisp Log Message: Added implementions of `redraw-input-buffer'. We ignore the `start-offset' argument, though. --- /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2005/02/22 14:00:18 1.21 +++ /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/11/22 14:15:52 1.22 @@ -399,3 +399,7 @@ (make-input-editing-stream-snapshot stream area) (redisplay-area area)))) nil) + +(defmethod redraw-input-buffer ((stream goatee-input-editing-mixin) &optional (start-position 0)) + (declare (ignore start-position)) + (redisplay-area (area stream))) From thenriksen at common-lisp.net Wed Nov 22 14:15:53 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:15:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061122141553.1D39B5B05C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv30056/Drei Modified Files: input-editor.lisp Log Message: Added implementions of `redraw-input-buffer'. We ignore the `start-offset' argument, though. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/18 20:59:28 1.5 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/11/22 14:15:53 1.6 @@ -496,6 +496,13 @@ (update-syntax (buffer drei) (syntax (buffer drei))) (display-drei drei))) +(defmethod redraw-input-buffer ((stream drei-input-editing-mixin) + &optional (start-position 0)) + (declare (ignore start-position)) + ;; We ignore `start-position', because it would be more work to + ;; figure out what to redraw than to just redraw everything. + (display-drei (drei-instance stream))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; `Add-input-editor-command' From thenriksen at common-lisp.net Wed Nov 22 14:15:55 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:15:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061122141555.21D365B068@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv30056 Modified Files: decls.lisp Log Message: Added implementions of `redraw-input-buffer'. We ignore the `start-offset' argument, though. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/11/08 01:18:22 1.40 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/11/22 14:15:53 1.41 @@ -552,6 +552,7 @@ ;;; 24.1 The Input Editor (defgeneric input-editor-format (stream format-string &rest args)) +(defgeneric redraw-input-buffer (stream &optional start-from)) ;;; 24.1.1 The Input Editing Stream Protocol From thenriksen at common-lisp.net Wed Nov 22 14:23:22 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:23:22 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Goatee Message-ID: <20061122142322.3F7A61A09E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Goatee In directory clnet:/tmp/cvs-serv31901/Goatee Modified Files: editing-stream.lisp Log Message: When Goatee's insertion-pointer is set, actually move point. --- /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/11/22 14:15:52 1.22 +++ /project/mcclim/cvsroot/mcclim/Goatee/editing-stream.lisp 2006/11/22 14:23:22 1.23 @@ -263,6 +263,9 @@ (setf (point* buffer) (location*-offset buffer pointer)) (redisplay-area area))) +(defmethod (setf stream-insertion-pointer) :after + ((new-value integer) (stream goatee-input-editing-mixin)) + (set-editing-stream-insertion-pointer stream new-value)) (defun %replace-input (stream new-input start end buffer-start rescan rescan-supplied-p From thenriksen at common-lisp.net Wed Nov 22 14:53:12 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:53:12 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061122145312.D6A8F710F9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv3352/ESA Modified Files: esa-io.lisp Log Message: Added new presentation methods for pathnames, based on the ones in ESA. We now have completion and an attempt at handling the multide of evils that a programmer can inflict upon a poor CLIM implementations attempt to textually represent a pathname object. I do not claim these methods are fail-proof, so please show some restraints wrt. what kind of nastyness you feed them. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/08 01:10:16 1.1 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/22 14:53:12 1.2 @@ -43,97 +43,6 @@ (make-command-table 'esa-io-table :errorp nil) -(defun filename-completer (so-far mode) - (flet ((remove-trail (s) - (subseq s 0 (let ((pos (position #\/ s :from-end t))) - (if pos (1+ pos) 0))))) - (let* ((directory-prefix - (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) - "" - (namestring #+sbcl *default-pathname-defaults* - #+cmu (ext:default-directory) - #-(or sbcl cmu) *default-pathname-defaults*))) - (full-so-far (concatenate 'string directory-prefix so-far)) - (pathnames - (loop with length = (length full-so-far) - and wildcard = (concatenate 'string (remove-trail so-far) "*.*") - for path in - #+(or sbcl cmu lispworks) (directory wildcard) - #+openmcl (directory wildcard :directories t) - #+allegro (directory wildcard :directories-are-files nil) - #+cormanlisp (nconc (directory wildcard) - (cl::directory-subdirs dirname)) - #-(or sbcl cmu lispworks openmcl allegro cormanlisp) - (directory wildcard) - when (let ((mismatch (mismatch (namestring path) full-so-far))) - (or (null mismatch) (= mismatch length))) - collect path)) - (strings (mapcar #'namestring pathnames)) - (first-string (car strings)) - (length-common-prefix nil) - (completed-string nil) - (full-completed-string nil) - (input-is-directory-p (when (plusp (length so-far)) - (char= (aref so-far (1- (length so-far))) #\/)))) - (unless (null pathnames) - (setf length-common-prefix - (loop with length = (length first-string) - for string in (cdr strings) - do (setf length (min length (or (mismatch string first-string) length))) - finally (return length)))) - (unless (null pathnames) - (setf completed-string - (subseq first-string (length directory-prefix) - (if (null (cdr pathnames)) nil length-common-prefix))) - (setf full-completed-string - (concatenate 'string directory-prefix completed-string))) - (case mode - ((:complete-limited :complete-maximal) - (cond ((null pathnames) - (values so-far nil nil 0 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - (input-is-directory-p - (values completed-string t (parse-namestring so-far) (length pathnames) nil)) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:complete - (cond ((null pathnames) - (values so-far t so-far 1 nil)) - ((null (cdr pathnames)) - (values completed-string t (car pathnames) 1 nil)) - ((find full-completed-string strings :test #'string-equal) - (let ((pos (position full-completed-string strings :test #'string-equal))) - (values completed-string - t (elt pathnames pos) (length pathnames) nil))) - (input-is-directory-p - (values completed-string t (parse-namestring so-far) (length pathnames) nil)) - (t - (values completed-string nil nil (length pathnames) nil)))) - (:possibilities - (values nil nil nil (length pathnames) - (loop with length = (length directory-prefix) - for name in pathnames - collect (list (subseq (namestring name) length nil) - name)))))))) - -(define-presentation-method present (object (type pathname) - stream (view textual-view) &key) - (princ (namestring object) stream)) - -(define-presentation-method accept ((type pathname) stream (view textual-view) - &key (default nil defaultp) (default-type type)) - (multiple-value-bind (pathname success string) - (complete-input stream - #'filename-completer - :allow-any-input t) - (cond (success - (values pathname type)) - ((and (zerop (length string)) - defaultp) - (values default default-type)) - (t (values string 'string))))) - ;;; Adapted from cl-fad/PCL (defun directory-pathname-p (pathspec) "Returns NIL if PATHSPEC does not designate a directory." From thenriksen at common-lisp.net Wed Nov 22 14:53:13 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 09:53:13 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061122145313.5A489A0F0@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3352 Modified Files: presentation-defs.lisp Log Message: Added new presentation methods for pathnames, based on the ones in ESA. We now have completion and an attempt at handling the multide of evils that a programmer can inflict upon a poor CLIM implementations attempt to textually represent a pathname object. I do not claim these methods are fail-proof, so please show some restraints wrt. what kind of nastyness you feed them. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/20 09:00:56 1.59 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/22 14:53:12 1.60 @@ -1448,27 +1448,144 @@ (define-presentation-method presentation-typep (object (type pathname)) (pathnamep object)) +(define-presentation-method present ((object pathname) (type pathname) + stream (view textual-view) &key) + ;; XXX: We can only visually represent the pathname if it has a name + ;; - making it wild is a compromise. If the pathname is completely + ;; blank, we leave it as-is, though. + (let ((pathname (if (equal object #.(make-pathname)) + object + (merge-pathnames object (make-pathname :name :wild))))) + (princ pathname stream))) + +(define-presentation-method present ((object string) (type pathname) + stream (view textual-view) + &rest args &key) + (apply-presentation-generic-function + present (pathname object) type stream view args)) + (defmethod presentation-type-of ((object pathname)) 'pathname) -(define-presentation-method present (object (type pathname) stream - (view textual-view) - &key acceptably for-context-type) - (declare (ignore acceptably for-context-type)) - (princ object stream)) - -(define-presentation-method accept - ((type pathname) stream (view textual-view) - &key (default *default-pathname-defaults*)) - (let* ((namestring (read-token stream)) - (path (parse-namestring namestring))) - (if merge-default - (merge-pathnames - path - (merge-pathnames (make-pathname :type default-type - :version default-version) - default)) - path))) +(defun filename-completer (so-far mode) + (flet ((remove-trail (s) + (subseq s 0 (let ((pos (position #\/ s :from-end t))) + (if pos (1+ pos) 0))))) + (let* ((directory-prefix + (if (and (plusp (length so-far)) (eql (aref so-far 0) #\/)) + "" + (namestring #+sbcl *default-pathname-defaults* + #+cmu (ext:default-directory) + #-(or sbcl cmu) *default-pathname-defaults*))) + (full-so-far (concatenate 'string directory-prefix so-far)) + (pathnames + (loop with length = (length full-so-far) + and wildcard = (concatenate 'string (remove-trail so-far) "*.*") + for path in + #+(or sbcl cmu lispworks) (directory wildcard) + #+openmcl (directory wildcard :directories t) + #+allegro (directory wildcard :directories-are-files nil) + #+cormanlisp (nconc (directory wildcard) + (cl::directory-subdirs dirname)) + #-(or sbcl cmu lispworks openmcl allegro cormanlisp) + (directory wildcard) + when (let ((mismatch (mismatch (namestring path) full-so-far))) + (or (null mismatch) (= mismatch length))) + collect path)) + (strings (mapcar #'namestring pathnames)) + (first-string (car strings)) + (length-common-prefix nil) + (completed-string nil) + (full-completed-string nil) + (input-is-directory-p (when (plusp (length so-far)) + (char= (aref so-far (1- (length so-far))) #\/)))) + (unless (null pathnames) + (setf length-common-prefix + (loop with length = (length first-string) + for string in (cdr strings) + do (setf length (min length (or (mismatch string first-string) length))) + finally (return length)))) + (unless (null pathnames) + (setf completed-string + (subseq first-string (length directory-prefix) + (if (null (cdr pathnames)) nil length-common-prefix))) + (setf full-completed-string + (concatenate 'string directory-prefix completed-string))) + (case mode + ((:complete-limited :complete-maximal) + (cond ((null pathnames) + (values so-far nil nil 0 nil)) + ((null (cdr pathnames)) + (values completed-string (plusp (length so-far)) (car pathnames) 1 nil)) + (input-is-directory-p + (values completed-string t (parse-namestring so-far) (length pathnames) nil)) + (t + (values completed-string nil nil (length pathnames) nil)))) + (:complete + ;; This is reached when input is activated, if we did + ;; completion, that would mean that an input of "foo" would + ;; be expanded to "foobar" if "foobar" exists, even if the + ;; user actually *wants* the "foo" pathname (to create the + ;; file, for example). + (values so-far t so-far 1 nil)) + (:possibilities + (values nil nil nil (length pathnames) + (loop with length = (length directory-prefix) + for name in pathnames + collect (list (subseq (namestring name) length nil) + name)))))))) + +(define-presentation-method accept ((type pathname) stream (view textual-view) + &key (default *default-pathname-defaults* defaultp) + ((:default-type accept-default-type) type)) + (multiple-value-bind (pathname success string) + (complete-input stream + #'filename-completer + :allow-any-input t) + (cond ((and pathname success) + (values (if merge-default + (progn + (unless (or (pathname-type pathname) + (null default-type)) + (setf pathname (make-pathname :defaults pathname + :type default-type))) + (merge-pathnames pathname default default-version)) + pathname) + type)) + ((and (zerop (length string)) + defaultp) + (values default accept-default-type)) + (t (values string 'string))))) + +(defmethod presentation-replace-input :around + ((stream input-editing-stream) + (object pathname) (type (eql 'pathname)) + view &rest args &key &allow-other-keys) + ;; This is fully valid and compliant, but it still smells slightly + ;; like a hack. + (let ((name (pathname-name object)) + (directory (when (pathname-directory object) + (directory-namestring object))) + (type (pathname-type object)) + (string "") + (old-insp (stream-insertion-pointer stream))) + (setf string (or directory string)) + (setf string (concatenate 'string string + (cond ((and name type) + (file-namestring object)) + (name name) + (type (subseq + (namestring + (make-pathname + :name " " + :type type)) + 1))))) + (apply #'replace-input stream string args) + (when directory + (setf (stream-insertion-pointer stream) + (+ old-insp (if directory (length directory) 0))) + ;; If we moved the insertion pointer, this might be a good idea. + (redraw-input-buffer stream old-insp)))) (defgeneric default-completion-name-key (item)) From thenriksen at common-lisp.net Wed Nov 22 18:52:57 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 13:52:57 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061122185257.E45D433002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv4500/Drei Modified Files: drei-clim.lisp Log Message: The Drei gadget should now work under uncivilised (non-ratpoison) window managers, but having to call {armed|disarmed}-callback manually is ugly. This is basically how Goatee does it as well. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/18 20:59:28 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/22 18:52:57 1.9 @@ -210,7 +210,10 @@ climi::enter/exit-arms/disarms-mixin asynchronous-command-processor) ((%currently-processing :initform nil - :accessor currently-processing-p)) + :accessor currently-processing-p) + (%previous-focus :accessor previous-focus :initform nil + :documentation "The pane that previously had +keyboard focus")) (:default-initargs :command-executor 'execute-drei-command) (:documentation "An actual, instantiable Drei gadget with event-based command processing.")) @@ -241,13 +244,21 @@ (gadget-id gadget) new-value))) +;; It's really silly that we have to manage keyboard input focus +;; ourself. (defmethod armed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) + (let ((port (port gadget))) + (setf (previous-focus gadget) (port-keyboard-input-focus port)) + (setf (port-keyboard-input-focus port) gadget)) (setf (active gadget) t) (display-drei gadget)) (defmethod disarmed-callback :after ((gadget drei-gadget-pane) client id) (declare (ignore client id)) + (let ((port (port gadget))) + (setf (port-keyboard-input-focus port) (previous-focus gadget)) + (setf (previous-focus gadget) nil)) (setf (active gadget) nil) (display-drei gadget)) @@ -292,10 +303,10 @@ ;; When an `accept' is called during the execution of a command for ;; the Drei gadget, we must deactivate the gadget in order to not ;; eat keyboard events. - (unwind-protect (progn (deactivate-gadget drei) + (unwind-protect (progn (disarmed-callback drei t t) (funcall continuation)) (activate-gadget drei) - (setf (active drei) t))) + (armed-callback drei t t))) (defmethod additional-command-tables append ((drei drei-gadget-pane) (table drei-command-table)) From thenriksen at common-lisp.net Wed Nov 22 20:51:32 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 15:51:32 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061122205132.D0EF71C008@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22753/Drei Modified Files: drei-clim.lisp Log Message: "tompa" at #lisp reported that `gadget-value' snips off the last character, which it does. Fixed. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/22 18:52:57 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/22 20:51:32 1.10 @@ -228,7 +228,7 @@ (defmethod gadget-value ((gadget drei-gadget-pane)) (buffer-substring (buffer gadget) - 0 (max 0 (1- (size (buffer gadget)))))) + 0 (size (buffer gadget)))) (defmethod (setf gadget-value) (new-value (gadget drei-gadget-pane) &key (invoke-callback t)) From thenriksen at common-lisp.net Wed Nov 22 21:23:24 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 22 Nov 2006 16:23:24 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061122212324.55E8922010@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv28305/Drei Modified Files: packages.lisp buffer.lisp Log Message: Added `region-to-string' function and exported the `condition-offset' accessor. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/19 11:39:45 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/22 21:23:24 1.7 @@ -32,6 +32,7 @@ #:mark #:left-sticky-mark #:right-sticky-mark #:standard-left-sticky-mark #:standard-right-sticky-mark #:clone-mark + #:condition-offset #:no-such-offset #:offset-before-beginning #:offset-after-end #:invalid-motion #:motion-before-beginning #:motion-after-end #:size #:number-of-lines @@ -52,7 +53,7 @@ #:delete-buffer-range #:delete-range #:delete-region #:buffer-object #:buffer-sequence - #:object-before #:object-after #:region-to-sequence + #:object-before #:object-after #:region-to-sequence #:region-to-string #:low-mark #:high-mark #:modified-p #:clear-modify #:binseq-buffer #:obinseq-buffer #:binseq2-buffer #:persistent-left-sticky-mark #:persistent-right-sticky-mark --- /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/18 15:42:43 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/buffer.lisp 2006/11/22 21:23:24 1.4 @@ -665,6 +665,12 @@ (rotatef offset1 offset2)) (buffer-sequence (buffer mark1) offset1 offset2))) +(defun region-to-string (start end) + "Return a string of the contents of the buffer associated with +the marks, from `start' to `end', of which at least one must be a +mark object." + (coerce (region-to-sequence start end) 'string)) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Buffer modification protocol From thenriksen at common-lisp.net Thu Nov 23 15:48:48 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Nov 2006 10:48:48 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061123154848.675917D18F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13683/Drei Modified Files: drei-clim.lisp Log Message: Patch from Thomas Persson - Drei text fields now check whether a gesture is an activation gesture, and they call `value-changed-callback' --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/22 20:51:32 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/23 15:48:48 1.11 @@ -279,7 +279,11 @@ (display-message "Aborted"))) (display-drei drei) (when (modified-p (buffer drei)) - (clear-modify (buffer drei))))))) + (clear-modify (buffer drei)) + (value-changed-callback drei + (gadget-client drei) + (gadget-id drei) + (gadget-value drei))))))) (defmethod execute-drei-command :after ((drei drei-gadget-pane) command) (with-accessors ((buffer buffer)) drei From thenriksen at common-lisp.net Thu Nov 23 15:48:49 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Nov 2006 10:48:49 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061123154849.19D447D190@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv13683 Modified Files: text-editor-gadget.lisp Log Message: Patch from Thomas Persson - Drei text fields now check whether a gesture is an activation gesture, and they call `value-changed-callback' --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/10 18:40:41 1.3 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/23 15:48:48 1.4 @@ -61,6 +61,14 @@ (make-space-requirement :height height :max-height height :min-height height :min-width width :width width))))) +(defmethod handle-event ((gadget text-field-pane) (event key-press-event)) + (unless (and (drei::currently-processing-p gadget) + (drei::directly-processing-p gadget)) + (if (with-activation-gestures ((activation-gestures gadget)) + (activation-gesture-p (convert-to-gesture event))) + (activate-callback gadget (gadget-client gadget) (gadget-id gadget)) + (call-next-method)))) + (defmethod allocate-space ((pane text-field-pane) w h) (resize-sheet pane w h)) From thenriksen at common-lisp.net Thu Nov 23 17:21:38 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 23 Nov 2006 12:21:38 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061123172138.666E854122@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv27945 Modified Files: NEWS Log Message: Added note of the pathname presentation changes to NEWS. --- /project/mcclim/cvsroot/mcclim/NEWS 2006/11/19 18:09:07 1.8 +++ /project/mcclim/cvsroot/mcclim/NEWS 2006/11/23 17:21:38 1.9 @@ -6,6 +6,7 @@ *** Native implementation of context menus, list panes, label panes, and option panes. ** Improvement: Added new editor substrate ("Drei"). +** Improvement: Improved the pathname presentation methods considerably. * Changes in mcclim-0.9.3 "All Souls' Day" relative to 0.9.2: ** backend improvement: The Null backend now registers itself in the From ahefner at common-lisp.net Thu Nov 23 19:53:54 2006 From: ahefner at common-lisp.net (ahefner) Date: Thu, 23 Nov 2006 14:53:54 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061123195354.0A90733003@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv15618 Modified Files: esa-io.lisp Log Message: Filepath and buffer args were transposed in com-write-buffer. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/22 14:53:12 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2006/11/23 19:53:53 1.3 @@ -258,7 +258,7 @@ "Prompt for a filename and write the current buffer to it. Changes the file visted by the buffer to the given file." (let ((buffer (current-buffer))) - (write-buffer buffer filepath))) + (write-buffer filepath buffer))) (set-key `(com-write-buffer ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\w :control))) From thenriksen at common-lisp.net Fri Nov 24 18:37:55 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 24 Nov 2006 13:37:55 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20061124183755.0D8AF751A1@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv14107 Modified Files: package.lisp Log Message: Patch from Martin Raspaud to make the Listener compile when fasl directory != source directory. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2005/09/22 11:40:31 1.2 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/package.lisp 2006/11/24 18:37:54 1.3 @@ -9,4 +9,6 @@ (eval-when (:load-toplevel) ; (format t "~&~%!@#%^!@#!@ ... ~A~%~%" *load-truename*) - (defparameter *icon-path* (merge-pathnames #P"icons/" *load-truename*))) + (defparameter *icon-path* (merge-pathnames + #P"icons/" + (load-time-value (or #.*compile-file-pathname* *load-pathname*))))) From thenriksen at common-lisp.net Fri Nov 24 22:43:03 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 24 Nov 2006 17:43:03 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061124224303.D2DD271106@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17330/Drei Modified Files: packages.lisp drei-clim.lisp Log Message: Added new exported `handle-gesture' generic function and used this to implement the activation-gesture behavior for the text-field gadget, eliminating use of Drei-internal symbols. --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/22 21:23:24 1.7 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2006/11/24 22:43:03 1.8 @@ -226,6 +226,9 @@ #:with-bound-drei-special-variables #:accepting-from-user #:invoke-accepting-from-user + ;; Gadget interface stuff. + #:handle-gesture + ;; Input-editor interface stuff. #:drei-input-editing-mixin #:drei-instance #:object #:result-type --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/23 15:48:48 1.11 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/24 22:43:03 1.12 @@ -262,7 +262,16 @@ (setf (active gadget) nil) (display-drei gadget)) -(defun handle-new-gesture (drei gesture) +(defgeneric handle-gesture (drei gesture) + (:documentation "This generic function is called whenever a +Drei gadget variant has determined that a keyboard event +corresponds to a useful gesture that should be handled. A useful +gesture is, for example, one that is not simply a click on a +modifier key. When this function is called, the Drei special +variables (`*current-window*', `*current-buffer*', etc) are +properly bound.")) + +(defmethod handle-gesture ((drei drei-gadget-pane) gesture) (let ((*command-processor* drei) (*abort-gestures* *esa-abort-gestures*)) ;; It is important that the minibuffer of the Drei object is @@ -281,9 +290,9 @@ (when (modified-p (buffer drei)) (clear-modify (buffer drei)) (value-changed-callback drei - (gadget-client drei) - (gadget-id drei) - (gadget-value drei))))))) + (gadget-client drei) + (gadget-id drei) + (gadget-value drei))))))) (defmethod execute-drei-command :after ((drei drei-gadget-pane) command) (with-accessors ((buffer buffer)) drei @@ -301,7 +310,7 @@ (when (proper-gesture-p gesture) (with-bound-drei-special-variables (gadget :prompt (format nil "~A " (gesture-name gesture))) (let ((*standard-input* (or *minibuffer* *standard-input*))) - (handle-new-gesture gadget gesture)))))))) + (handle-gesture gadget gesture)))))))) (defmethod invoke-accepting-from-user ((drei drei-gadget-pane) (continuation function)) ;; When an `accept' is called during the execution of a command for From thenriksen at common-lisp.net Fri Nov 24 22:43:04 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 24 Nov 2006 17:43:04 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061124224304.5D65C710D2@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17330 Modified Files: text-editor-gadget.lisp Log Message: Added new exported `handle-gesture' generic function and used this to implement the activation-gesture behavior for the text-field gadget, eliminating use of Drei-internal symbols. --- /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/23 15:48:48 1.4 +++ /project/mcclim/cvsroot/mcclim/text-editor-gadget.lisp 2006/11/24 22:43:03 1.5 @@ -61,13 +61,11 @@ (make-space-requirement :height height :max-height height :min-height height :min-width width :width width))))) -(defmethod handle-event ((gadget text-field-pane) (event key-press-event)) - (unless (and (drei::currently-processing-p gadget) - (drei::directly-processing-p gadget)) - (if (with-activation-gestures ((activation-gestures gadget)) - (activation-gesture-p (convert-to-gesture event))) - (activate-callback gadget (gadget-client gadget) (gadget-id gadget)) - (call-next-method)))) +(defmethod drei:handle-gesture ((drei text-field-pane) gesture) + (if (with-activation-gestures ((activation-gestures drei)) + (activation-gesture-p gesture)) + (activate-callback drei (gadget-client drei) (gadget-id drei)) + (call-next-method))) (defmethod allocate-space ((pane text-field-pane) w h) (resize-sheet pane w h)) From dlichteblau at common-lisp.net Sat Nov 25 21:11:33 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 25 Nov 2006 16:11:33 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061125211133.865712E1B9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv29681 Modified Files: BUGS ffi.lisp gadgets.lisp Log Message: Second attempt at label pane layouting. (demodemo beautiful again, but probably not quite there yet, see bug 24) * ffi.lisp: Regenerated. * frame-manager.lisp (MAKE-PANE-2 GENERIC-OPTION-PANE): New. * gadgets.lisp (LABEL-PANE-EXTRA-WIDTH, -HEIGHT): New slots. ((REALIZE-NATIVE-WIDGET GTK-LABEL-PANE)): Set the inner gtk widget size according to our child's space requirements, then retrieve the outer gtk widget's size and save the diferrence. (COMPOSE-SPACE, *USE-FRONTEND-COMPOSE-SPACE*): Removed *u-f-c-s* again. ((COMPOSE-SPACE GTK-LABEL-PANE)): Removed. ((ALLOCATE-SPACE GTK-LABEL-PANE)): New method, takes size difference into account. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/11/05 18:49:13 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/BUGS 2006/11/25 21:11:33 1.13 @@ -124,3 +124,9 @@ interactor. Replacing the :min-height 800 in receivers.lisp with :min-height 400 :max-height 400 fixes that, but CLX doesn't have the same problem. + +24. + Weird problem in the text size test with the drei gadget in the label + pane: Resizing ends up resizing the one-line drei gadget, and doesn't + even do it in one step. Instead, it enlarges itself in a smooth + animation, taking several seconds to stabilize. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/20 19:53:44 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/25 21:11:33 1.6 @@ -1234,6 +1234,12 @@ (widget :pointer) ;GtkWidget * ) +(defcfun "gtk_widget_get_child_requisition" + :void + (widget :pointer) ;GtkWidget * + (requisition :pointer) ;GtkRequisition * + ) + (defcfun "gtk_widget_get_events" :int (widget :pointer) ;GtkWidget * @@ -1246,6 +1252,13 @@ (y :pointer) ;gint * ) +(defcfun "gtk_widget_get_size_request" + :void + (widget :pointer) ;GtkWidget * + (width :pointer) ;gint * + (height :pointer) ;gint * + ) + (defcfun "gtk_widget_grab_focus" :void (widget :pointer) ;GtkWidget * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/19 18:08:16 1.12 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/25 21:11:33 1.13 @@ -74,7 +74,9 @@ (defclass gtk-hscrollbar (native-scrollbar) ()) (defclass gtk-label-pane (native-widget-mixin label-pane) - ((label-pane-fixed :accessor label-pane-fixed))) + ((label-pane-fixed :accessor label-pane-fixed) + (label-pane-extra-width :accessor label-pane-extra-width) + (label-pane-extra-height :accessor label-pane-extra-height))) ;;;; Constructors @@ -94,9 +96,21 @@ (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) + (fixed (gtk_fixed_new)) + (child (car (sheet-children sheet)))) (gtk_container_add frame fixed) + (gtk_widget_show fixed) + (when child + (let* ((q (compose-space child)) + (width1 (space-requirement-width q)) + (height1 (space-requirement-height q))) + (gtk_widget_set_size_request fixed width1 height1) + (cffi:with-foreign-object (r 'gtkrequisition) + (gtk_widget_size_request frame r) + (cffi:with-foreign-slots ((width height) r gtkrequisition) + (setf (label-pane-extra-width sheet) (- width width1)) + (setf (label-pane-extra-height sheet) (- height height1)))))) + (setf (label-pane-fixed sheet) fixed) frame)) (defmethod container-put ((parent gtk-label-pane) parent-widget child x y) @@ -493,25 +507,21 @@ ;;; 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)) - (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)))))) + (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) + (setf (native-widget gadget) nil))))) (defmethod compose-space ((gadget gtk-menu-bar) &key width height) (declare (ignore width height)) @@ -531,12 +541,15 @@ :min-height height :max-height height))) (unless widgetp - (gtk_widget_destroy widget))))) + (gtk_widget_destroy widget) + (setf (native-widget gadget) nil))))) -(defmethod compose-space ((gadget gtk-label-pane) &key width height) - (declare (ignore width height)) - (let ((*use-frontend-compose-space* t)) - (call-next-method))) +(defmethod allocate-space ((pane label-pane) width height) + (when (sheet-children pane) + (move-sheet (first (sheet-children pane)) 0 0) + (allocate-space (first (sheet-children pane)) + (- width (label-pane-extra-width pane)) + (- height (label-pane-extra-height pane))))) ;;; Vermischtes From dlichteblau at common-lisp.net Sat Nov 25 21:14:53 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sat, 25 Nov 2006 16:14:53 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061125211453.7A0A63001E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv29938 Modified Files: event.lisp gtk-ffi.lisp Log Message: "Oops." Fixed some more bugs introduced with the FFI regeneration last week. * event.lisp (INVOKE-LATER): g_idle_add takes a pointer, not a long. * gtk-ffi.lisp (DEFCFUN): Don't check the cairo status of cairo_font_face_status. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/12 20:12:19 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/event.lisp 2006/11/25 21:14:53 1.14 @@ -403,7 +403,7 @@ (with-gtk () (let ((i (incf *later-counter*))) (setf (gethash i *later-table*) fun) - (g_idle_add (cffi:get-callback 'idle-function) i)))) + (g_idle_add (cffi:get-callback 'idle-function) (cffi:make-pointer i))))) (cffi:defcallback idle-function :int ((data :long)) ;hack --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/20 19:53:44 1.16 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gtk-ffi.lisp 2006/11/25 21:14:53 1.17 @@ -44,7 +44,8 @@ (defmacro defcfun (name rtype &rest argtypes) (if (and (eq rtype 'cairo_status_t) - (not (equal name "cairo_status"))) + (not (or (equal name "cairo_status") + (equal name "cairo_font_face_status")))) `(def-cairo-fun ,name ,rtype , at argtypes) `(cffi:defcfun (,name ,(intern (string-upcase name) :clim-gtkairo)) ,rtype From dlichteblau at common-lisp.net Sun Nov 26 17:54:08 2006 From: dlichteblau at common-lisp.net (dlichteblau) Date: Sun, 26 Nov 2006 12:54:08 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Backends/gtkairo Message-ID: <20061126175408.941A733002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/gtkairo In directory clnet:/tmp/cvs-serv3899 Modified Files: ffi.lisp gadgets.lisp Log Message: Implement DE-/ACTIVATE-GADGET natively. * ffi.lisp: Regenerated. * gagets.lisp ((realize-native-widget :around) (activate-gadget :after native-widget-mixin) (deactivate-gadget :after native-widget-mixin)): De/activate the widget. --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/25 21:11:33 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/ffi.lisp 2006/11/26 17:54:08 1.7 @@ -1293,6 +1293,12 @@ (events :int) ;gint ) +(defcfun "gtk_widget_set_sensitive" + :void + (widget :pointer) ;GtkWidget * + (sensitive :int) ;gboolean + ) + (defcfun "gtk_widget_set_size_request" :void (widget :pointer) ;GtkWidget * --- /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/25 21:11:33 1.13 +++ /project/mcclim/cvsroot/mcclim/Backends/gtkairo/gadgets.lisp 2006/11/26 17:54:08 1.14 @@ -585,6 +585,21 @@ (gtk_toggle_button_set_active (mirror-widget mirror) (if value 1 0)))))) +(defmethod realize-native-widget :around ((gadget native-widget-mixin)) + (let ((widget (call-next-method))) + (gtk_widget_set_sensitive widget (if (gadget-active-p gadget) 1 0)) + widget)) + +(defmethod activate-gadget :after ((gadget native-widget-mixin)) + (with-gtk () + (when (native-widget gadget) + (gtk_widget_set_sensitive (native-widget gadget) 1)))) + +(defmethod deactivate-gadget :after ((gadget native-widget-mixin)) + (with-gtk () + (when (native-widget gadget) + (gtk_widget_set_sensitive (native-widget gadget) 0)))) + ;;; Scroll bars. From thenriksen at common-lisp.net Mon Nov 27 07:44:47 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Mon, 27 Nov 2006 02:44:47 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20061127074447.DAD3534000@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17221 Modified Files: presentation-defs.lisp input-editing-drei.lisp Log Message: The presentation history functions are now named more sensibly. Also, a change to `accept': we add the object to the presentation history of the type that was asked for, not the type that was returned. Input history should work in the Listener now (but there are still issues for non-trivial forms, unfortunately). --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/22 14:53:12 1.60 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2006/11/27 07:44:46 1.61 @@ -500,6 +500,18 @@ finally (return (values nil nil)))) (defun presentation-history-next (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))))) + +(defun presentation-history-previous (history ptype) (let ((first-object (goatee::forward history))) (loop for first-time = t then nil @@ -511,18 +523,6 @@ 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) , at body)) @@ -723,7 +723,7 @@ (let* ((default-from-history (and (not defaultp) provide-default)) (history (get-history)) (results - (multiple-value-list + (multiple-value-list (if history (let ((*active-history-type* real-history-type)) (cond (defaultp @@ -746,7 +746,7 @@ (when results-history (presentation-history-add results-history (car results) - (cadr results))) + real-type)) (values-list results))))))) (defmethod stream-accept ((stream standard-extended-input-stream) type --- /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/11/20 09:00:56 1.2 +++ /project/mcclim/cvsroot/mcclim/input-editing-drei.lisp 2006/11/27 07:44:46 1.3 @@ -199,16 +199,8 @@ ;;; 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) + (declare (ignore input-buffer gesture numeric-argument)) (let* ((accepting-type *active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) @@ -219,6 +211,7 @@ (presentation-replace-input stream object type (stream-default-view stream))))))) (defun history-yank-previous (stream input-buffer gesture numeric-argument) + (declare (ignore input-buffer gesture numeric-argument)) (let* ((accepting-type *active-history-type*) (history (and accepting-type (presentation-type-history accepting-type)))) @@ -228,8 +221,6 @@ (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-next) -(add-input-editor-command '((#\n :meta)) 'history-yank-previous) +(add-input-editor-command '((#\p :meta)) 'history-yank-previous) From rstrandh at common-lisp.net Mon Nov 27 11:54:50 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 27 Nov 2006 06:54:50 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20061127115450.248414C005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv15811/ESA Modified Files: esa.lisp Log Message: Make the ESA example work again after recent changes. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/18 20:47:46 1.2 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2006/11/27 11:54:49 1.3 @@ -1559,8 +1559,8 @@ (defclass example-pane (esa-pane-mixin application-pane) ((contents :initform "hello" :accessor contents))) -(define-application-frame example (standard-application-frame - esa-frame-mixin) +(define-application-frame example (esa-frame-mixin + standard-application-frame) () (:panes (window (let* ((my-pane From rstrandh at common-lisp.net Mon Nov 27 12:28:02 2006 From: rstrandh at common-lisp.net (rstrandh) Date: Mon, 27 Nov 2006 07:28:02 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061127122802.1EF3A4D002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21171/Drei Modified Files: lisp-syntax.lisp Log Message: Make Drei handle package names given as options at the beginning of the buffer. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/22 13:50:44 1.6 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/11/27 12:28:01 1.7 @@ -1376,7 +1376,7 @@ (let ((osp (option-specified-package syntax))) (typecase osp (package osp) - (string osp))) + (string (find-package osp)))) (find-package (option-specified-package syntax)) (find-package :clim-user))))) From thenriksen at common-lisp.net Tue Nov 28 23:34:10 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 28 Nov 2006 18:34:10 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061128233410.6873334002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21217 Modified Files: kill-ring.lisp Log Message: Oops. This should obviously be `setf' and not `set'. --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/19 11:39:45 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/28 23:34:10 1.3 @@ -118,8 +118,8 @@ (unless (typep size 'integer) (error "Error, ~S, is not an integer value" size)) (if (< size 5) - (set (slot-value kr 'max-size) 5) - (setf (slot-value kr 'max-size) size)) + (setf (slot-value kr 'max-size) 5) + (setf (slot-value kr 'max-size) size)) (let ((len (kill-ring-length kr))) (if (> len size) (loop for n from 1 to (- len size) From thenriksen at common-lisp.net Wed Nov 29 09:39:58 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 29 Nov 2006 04:39:58 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061129093958.2B08A2F044@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv17375 Modified Files: editing.lisp Log Message: Hm! Apparently we need different transposition methods for left- and right-sticky-marks. --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/14 10:31:37 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/29 09:39:57 1.3 @@ -166,7 +166,7 @@ (:documentation ,(concat "Transpose two " plural " at MARK."))) (defmethod ,transpose - (mark syntax) + ((mark right-sticky-mark) syntax) (let (start1 end1 start2 end2) (,backward mark syntax 1 nil) (setf start1 (clone-mark mark)) @@ -190,7 +190,33 @@ (insert-sequence mark obj2) (update-syntax (buffer syntax) syntax) - (,forward mark syntax 1 nil)))))))) + (,forward mark syntax 1 nil)))) + (defmethod ,transpose + ((mark left-sticky-mark) syntax) + (let (start1 end1 start2 end2) + (,backward mark syntax 1 nil) + (setf start1 (clone-mark mark)) + (,forward mark syntax 1 #'error-limit-action) + (setf end1 (clone-mark mark)) + (,forward mark syntax 1 #'error-limit-action) + (setf end2 (clone-mark mark)) + (,backward mark syntax 1 nil) + (setf start2 (clone-mark mark)) + (let ((obj1 (buffer-sequence (buffer mark) (offset start1) (offset end1))) + (obj2 (buffer-sequence (buffer mark) (offset start2) (offset end2)))) + (,forward-delete mark syntax 1 nil) + (insert-sequence mark obj1) + (,forward mark syntax 1 nil) + ;; KLUDGE: Having to do this manually is ugly, but it + ;; is necessary if the motion functions uses syntax + ;; information. + (update-syntax (buffer syntax) + syntax) + (,backward mark syntax 2 nil) + (,forward-delete mark syntax 1 nil) + (insert-sequence mark obj2) + (update-syntax (buffer syntax) + syntax)))))))) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; From thenriksen at common-lisp.net Wed Nov 29 09:59:01 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Wed, 29 Nov 2006 04:59:01 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061129095901.6627F3200E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv19881 Modified Files: editing.lisp Log Message: We also need different line-transposition methods for left- and right-sticky-marks. --- /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/29 09:39:57 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/editing.lisp 2006/11/29 09:59:00 1.4 @@ -299,7 +299,7 @@ ;; Autogenerated TRANSPOSE-LINES is not good enough. (defmethod transpose-lines - (mark syntax) + ((mark left-sticky-mark) syntax) (beginning-of-line mark) (unless (beginning-of-buffer-p mark) (backward-line mark syntax)) @@ -312,11 +312,28 @@ (unless (end-of-buffer-p mark) (delete-range mark)) (end-of-line mark) - (insert-object mark #\Newline) (forward-line mark syntax 0) (insert-sequence mark line) (insert-object mark #\Newline))) +(defmethod transpose-lines + ((mark right-sticky-mark) syntax) + (beginning-of-line mark) + (unless (beginning-of-buffer-p mark) + (backward-line mark syntax)) + (let* ((bol (offset mark)) + (eol (progn (end-of-line mark) + (offset mark))) + (line (buffer-sequence (buffer mark) bol eol))) + (delete-region bol mark) + ;; Remove newline at end of line as well. + (unless (end-of-buffer-p mark) + (delete-range mark)) + (end-of-line mark) + (insert-object mark #\Newline) + (forward-line mark syntax 0) + (insert-sequence mark line))) + ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; ;;; Word editing From thenriksen at common-lisp.net Thu Nov 30 17:00:09 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 30 Nov 2006 12:00:09 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061130170009.9F0FD702F9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv2898 Modified Files: motion.lisp Log Message: Improved the page and paragraph motion methods. Basically, my philosophy is that all the unit methods must behave similarly wrt. where they move to within the seperator whitespace. This will mean that the Climacs paragraph motion commands are not identical to those of Emacs, but I believe the consistency is worth this. --- /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/18 22:02:41 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/motion.lisp 2006/11/30 17:00:09 1.3 @@ -351,8 +351,13 @@ reached.")) (defmethod forward-one-page (mark syntax) - (when (search-forward mark (coerce (page-delimiter syntax) 'vector)) - t)) + (unless (end-of-buffer-p mark) + (forward-object mark 1) + (if (search-forward mark (coerce (page-delimiter syntax) 'vector)) + (progn (backward-object mark (length (page-delimiter syntax))) + t) + (progn (end-of-buffer mark) + nil)))) (defgeneric backward-one-page (mark syntax) (:documentation @@ -361,9 +366,13 @@ reached.")) (defmethod backward-one-page (mark syntax) - (when (search-backward mark (coerce (page-delimiter syntax) 'vector)) - (forward-object mark) - t)) + (unless (beginning-of-buffer-p mark) + (backward-object mark 1) + (if (search-backward mark (coerce (page-delimiter syntax) 'vector)) + (progn (forward-object mark (length (page-delimiter syntax))) + t) + (progn (beginning-of-buffer mark) + nil)))) (define-motion-fns page) @@ -464,9 +473,13 @@ Return T if successful, or NIL if the buffer limit was reached.")) (defmethod backward-one-paragraph (mark syntax) - (when (search-backward mark (coerce (paragraph-delimiter syntax) 'vector)) - (forward-object mark) - t)) + (unless (beginning-of-buffer-p mark) + (backward-object mark 1) + (if (search-backward mark (coerce (paragraph-delimiter syntax) 'vector)) + (progn (forward-object mark (length (paragraph-delimiter syntax))) + t) + (progn (beginning-of-buffer mark) + nil)))) (defgeneric forward-one-paragraph (mark syntax) (:documentation @@ -474,9 +487,13 @@ Return T if successful, or NIL if the buffer limit was reached.")) (defmethod forward-one-paragraph (mark syntax) - (when (search-forward mark (coerce (paragraph-delimiter syntax) 'vector)) - (backward-object mark) - t)) + (unless (end-of-buffer-p mark) + (forward-object mark 1) + (if (search-forward mark (coerce (paragraph-delimiter syntax) 'vector)) + (progn (backward-object mark (length (paragraph-delimiter syntax))) + t) + (progn (end-of-buffer mark) + nil)))) (define-motion-fns paragraph) From thenriksen at common-lisp.net Thu Nov 30 17:33:31 2006 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 30 Nov 2006 12:33:31 -0500 (EST) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20061130173331.A3AA951002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv7984 Modified Files: drei.lisp Log Message: Fixed `with-bound-drei-special-variables' to also allow null values. --- /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/19 11:39:45 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/drei.lisp 2006/11/30 17:33:31 1.9 @@ -706,17 +706,17 @@ (princ c minibuffer)))))) (defmacro with-bound-drei-special-variables ((drei-instance &key - current-buffer - current-window - current-mark - current-point - current-syntax - kill-ring - minibuffer - command-parser - partial-command-parser - previous-command - prompt) + (current-buffer nil current-buffer-p) + (current-window nil current-window-p) + (current-mark nil current-mark-p) + (current-point nil current-point-p) + (current-syntax nil current-syntax-p) + (kill-ring nil kill-ring-p) + (minibuffer nil minibuffer-p) + (command-parser nil command-parser-p) + (partial-command-parser nil partial-command-parser-p) + (previous-command nil previous-command-p) + (prompt nil prompt-p)) &body body) "Evaluate `body' with a set of Drei special variables (`*current-buffer*', `*current-window*', @@ -731,17 +731,28 @@ variables, but also some CLIM special variables needed for ESA-style command parsing." (once-only (drei-instance) - `(let* ((*current-buffer* ,(or current-buffer `(buffer ,drei-instance))) - (*current-window* ,(or current-window drei-instance)) - (*current-mark* ,(or current-mark `(mark ,drei-instance))) - (*current-point* ,(or current-point `(point ,drei-instance))) - (*current-syntax* ,(or current-syntax `(syntax *current-buffer*))) - (*kill-ring* ,(or kill-ring `(kill-ring ,drei-instance))) - (*minibuffer* ,(or minibuffer `(or (minibuffer ,drei-instance) *minibuffer*))) - (*command-parser* ,(or command-parser ''esa-command-parser)) - (*partial-command-parser* ,(or partial-command-parser ''esa-partial-command-parser)) - (*previous-command* ,(or previous-command `(previous-command ,drei-instance))) - (*extended-command-prompt* ,(or prompt "Extended command: "))) + `(let* ((*current-buffer* ,(if current-buffer-p current-buffer + `(buffer ,drei-instance))) + (*current-window* ,(if current-window-p current-window + drei-instance)) + (*current-mark* ,(if current-mark-p current-mark + `(mark ,drei-instance))) + (*current-point* ,(if current-point-p current-point + `(point ,drei-instance))) + (*current-syntax* ,(if current-syntax-p current-syntax + `(syntax *current-buffer*))) + (*kill-ring* ,(if kill-ring-p kill-ring + `(kill-ring ,drei-instance))) + (*minibuffer* ,(if minibuffer-p minibuffer + `(or (minibuffer ,drei-instance) *minibuffer*))) + (*command-parser* ,(if command-parser-p command-parser + ''esa-command-parser)) + (*partial-command-parser* ,(if partial-command-parser-p partial-command-parser + ''esa-partial-command-parser)) + (*previous-command* ,(if previous-command-p previous-command + `(previous-command ,drei-instance))) + (*extended-command-prompt* ,(if prompt-p prompt + "Extended command: "))) , at body))) (defgeneric invoke-performing-drei-operations (drei continuation &key with-undo update-syntax redisplay)