mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim
by thenriksen 20 Apr '08

20 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv4340 Modified Files: commands.lisp Log Message: Fixed broken :insert-default t in command parameters. It wasn't being passed along in the call to ACCEPT in the acceptor. I feel a bit odd about this fix, because I vaguely recall that this used to work, at least in Climacs, but the code pretty obviously filtered :insert-default keywords away. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/15 19:52:57 1.78 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/20 07:19:10 1.79 @@ -663,7 +663,7 @@ (defun accept-form-for-argument (stream arg) (let ((accept-keys '(:default :default-type :display-default - :prompt :documentation))) + :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args &key (mentioned-default nil mentioned-default-p) &allow-other-keys) @@ -692,7 +692,7 @@ (defun accept-form-for-argument-partial (stream ptype-arg command-arg original-command-arg ) (let ((accept-keys '(:default :default-type :display-default - :prompt :documentation))) + :prompt :documentation :insert-default))) (destructuring-bind (name ptype &rest key-args) ptype-arg (declare (ignore name))

1 0

[mcclim-cvs] CVS playpen
by ahefner 20 Apr '08

20 Apr '08

Update of /project/mcclim/cvsroot/playpen In directory clnet:/tmp/cvs-serv12245 Log Message: Initial import. Status: Vendor Tag: initial Release Tags: start N playpen/playpen.asd N playpen/scratch.text N playpen/src/package.lisp N playpen/src/windowing.h N playpen/src/wtest_1.c N playpen/src/x11.c No conflicts created by this import

2 1

[mcclim-cvs] CVS mcclim
by thenriksen 19 Apr '08

19 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11778 Modified Files: presentation-defs.lisp Log Message: Fixed STRING-INPUT-EDITING-STREAM to not fail on many common use cases. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 07:51:22 1.76 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 09:26:49 1.77 @@ -1047,12 +1047,13 @@ (defmethod stream-read-gesture ((stream string-input-editing-stream) &key peek-p &allow-other-keys) - (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) - (second (first (gethash (first *activation-gestures*) - climi::*gesture-names*))) ; XXX - will always be non-NIL? - (aref (stream-input-buffer stream) (stream-scan-pointer stream))) - (unless peek-p - (incf (stream-scan-pointer stream))))) + (unless (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (second (first (gethash (first *activation-gestures*) + climi::*gesture-names*))) ; XXX - will always be non-NIL? + (aref (stream-input-buffer stream) (stream-scan-pointer stream))) + (unless peek-p + (incf (stream-scan-pointer stream)))))) (defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture) (decf (stream-scan-pointer stream)))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 19 Apr '08

19 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24668 Modified Files: presentation-defs.lisp Log Message: Fix the utterly broken ACCEPT-FROM-STRING to at least work for common cases. Still WIP. --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/02/01 17:02:55 1.75 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 07:51:22 1.76 @@ -964,6 +964,102 @@ (declare (ignore type view other-args)) nil) +;;; For ACCEPT-FROM-STRING, use this barebones input-editing-stream. +(defclass string-input-editing-stream (input-editing-stream fundamental-character-input-stream) + ((input-buffer :accessor stream-input-buffer) + (insertion-pointer :accessor stream-insertion-pointer + :initform 0 + :documentation "This is not used for anything at any point.") + (scan-pointer :accessor stream-scan-pointer + :initform 0 + :documentation "This is not used for anything at any point.")) + (:documentation "An implementation of the input-editing stream +protocol retrieving gestures from a provided string.")) + +(defmethod initialize-instance :after ((stream string-input-editing-stream) + &key (string (error "A string must be provided")) + (start 0) (end (length string)) + &allow-other-keys) + (setf (stream-input-buffer stream) + (replace (make-array (- end start) :fill-pointer (- end start)) + string :start1 start :end2 end))) + +(defmethod stream-element-type ((stream string-input-editing-stream)) + 'character) + +(defmethod close ((stream string-input-editing-stream) &key abort) + (declare (ignore abort))) + +(defmethod stream-peek-char ((stream string-input-editing-stream)) + (let ((char (read-char-no-hang stream nil nil))) + (when char + (unread-char char stream)) + (or char :eof))) + +(defmethod stream-read-char-no-hang ((stream string-input-editing-stream)) + (if (> (stream-scan-pointer stream) (length (stream-input-buffer stream))) + :eof + (stream-read-gesture stream))) + +(defmethod stream-read-char ((stream string-input-editing-stream)) + (stream-read-gesture stream)) + +(defmethod stream-listen ((stream string-input-editing-stream)) + (< (stream-scan-pointer stream) (length (stream-input-buffer stream)))) + +(defmethod stream-unread-char ((stream string-input-editing-stream) char) + (stream-unread-gesture stream char)) + +(defmethod invoke-with-input-editor-typeout ((stream string-input-editing-stream) continuation + &key erase) + (declare (ignore erase))) + +(defmethod input-editor-format ((stream string-input-editing-stream) format-string + &rest args) + (declare (ignore args))) + +(defmethod stream-rescanning-p ((stream string-input-editing-stream)) + t) + +(defmethod reset-scan-pointer ((stream string-input-editing-stream) + &optional scan-pointer) + (declare (ignore scan-pointer))) + +(defmethod immediate-rescan ((stream string-input-editing-stream))) + +(defmethod queue-rescan ((stream string-input-editing-stream))) + +(defmethod rescan-if-necessary ((stream string-input-editing-stream) + &optional inhibit-activation) + (declare (ignore inhibit-activation))) + +(defmethod erase-input-buffer ((stream string-input-editing-stream) + &optional start-position) + (declare (ignore start-position))) + +(defmethod redraw-input-buffer ((stream string-input-editing-stream) + &optional start-position) + (declare (ignore start-position))) + +(defmethod stream-process-gesture ((stream string-input-editing-stream) gesture type) + (when (characterp gesture) + (values gesture type))) + +(defmethod stream-read-gesture ((stream string-input-editing-stream) + &key peek-p &allow-other-keys) + (prog1 (if (= (stream-scan-pointer stream) (length (stream-input-buffer stream))) + (second (first (gethash (first *activation-gestures*) + climi::*gesture-names*))) ; XXX - will always be non-NIL? + (aref (stream-input-buffer stream) (stream-scan-pointer stream))) + (unless peek-p + (incf (stream-scan-pointer stream))))) + +(defmethod stream-unread-gesture ((stream string-input-editing-stream) gesture) + (decf (stream-scan-pointer stream))) + +(defmethod stream-accept ((stream string-input-editing-stream) type &rest args) + (apply #'accept-1 stream type args)) + ;;; XXX This needs work! It needs to do everything that accept does for ;;; expanding ptypes and setting up recursive call procesusing (defun accept-from-string (type string @@ -982,7 +1078,7 @@ (start 0) (end (length string))) (declare (ignore view)) - ;;; XXX work in progress here. + ;; XXX work in progress here. (with-activation-gestures ((if additional-activations-p additional-activation-gestures activation-gestures) @@ -999,13 +1095,12 @@ type) 0)) (simple-parse-error "Empty string"))) - (let ((index 0)) + (let ((stream (make-instance 'string-input-editing-stream + :string string :start start :end end))) (multiple-value-bind (val ptype) - (with-input-from-string (stream string :start start :end end - :index index) - (with-keywords-removed (args (:start :end)) - (apply #'stream-accept stream type :view +textual-view+ args))) - (values val ptype index)))) + (with-keywords-removed (args (:start :end)) + (apply #'stream-accept stream type :history nil :view +textual-view+ args)) + (values val ptype (+ (stream-scan-pointer stream) start))))) (define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test

1 0

[mcclim-cvs] CVS mcclim/Apps/Listener
by thenriksen 18 Apr '08

18 Apr '08

Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv2123/Apps/Listener Modified Files: icons.lisp Log Message: Explicitly provide a :port nil argument to make-pattern-from-bitmap-file so that no port thread will be started by the Listener at load-time. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/04/14 16:46:28 1.8 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/icons.lisp 2008/04/18 11:46:40 1.9 @@ -35,7 +35,8 @@ (defmacro deficon (var pathname) `(eval-when (:load-toplevel :execute) (defparameter ,var (make-pattern-from-bitmap-file - ,(merge-pathnames pathname *icon-path*) :format :xpm)))) + ,(merge-pathnames pathname *icon-path*) + :format :xpm :port nil)))) (defvar *icon-cache* (make-hash-table :test #'equal)) @@ -46,7 +47,7 @@ (make-pattern-from-bitmap-file (merge-pathnames (parse-namestring filename) *icon-path*) - :format :xpm)))) + :format :xpm :port nil)))) ;; Don't particularly need these any more.. (deficon *folder-icon* #P"folder.xpm")

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 18 Apr '08

18 Apr '08

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29836/Drei Modified Files: search-commands.lisp Log Message: Fixed silly bug in Drei search/replace. --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/01/30 11:48:40 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/18 11:22:29 1.9 @@ -424,7 +424,7 @@ (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) - (mark (point (drei-instance targets)))) + (mark (point (view (drei-instance targets))))) (backward-object mark string1-length) (replace-one-string mark string1-length @@ -443,7 +443,7 @@ (occurrences occurrences) (targets targets)) state (let ((string1-length (length string1)) - (mark (point (drei-instance targets)))) + (mark (point (view (drei-instance targets))))) (loop do (backward-object mark string1-length) (replace-one-string mark string1-length

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 Apr '08

15 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv17042 Modified Files: menu.lisp Log Message: Made command menu panes less broken. --- /project/mcclim/cvsroot/mcclim/menu.lisp 2008/01/29 19:13:07 1.39 +++ /project/mcclim/cvsroot/mcclim/menu.lisp 2008/04/15 21:15:22 1.40 @@ -461,9 +461,9 @@ (find-command-table (command-menu-item-value item)) stream args))) ((eq (command-menu-item-type item) :command) - (let ((name (command-name (command-menu-item-value item)))) - (when (command-line-name-for-command name command-table :errorp nil) - (present name 'command-name :stream stream))))))) + (let ((name (command-menu-item-name item))) + (with-output-as-presentation (stream (command-menu-item-value item) 'command) + (write-string name stream))))))) command-table))) (defmethod display-command-menu (frame (stream fundamental-output-stream)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 Apr '08

15 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31942 Modified Files: commands.lisp Log Message: Fixed the addition of menu items to empty menus. --- /project/mcclim/cvsroot/mcclim/commands.lisp 2008/02/02 00:10:18 1.77 +++ /project/mcclim/cvsroot/mcclim/commands.lisp 2008/04/15 19:52:57 1.78 @@ -415,18 +415,20 @@ (defun %add-menu-item (command-table item after) (with-slots (menu) command-table + (when (null menu) + (setf after :start)) (case after (:start (push item menu)) ((:end nil) (setf menu (nconc menu (list item)))) (:sort (setf menu (sort (cons item menu) - #'string-lessp - :key #'command-menu-item-name))) + #'string-lessp + :key #'command-menu-item-name))) (t (push item - (cdr (member after menu - :key #'command-menu-item-name - :test #'string-equal)))))) + (cdr (member after menu + :key #'command-menu-item-name + :test #'string-equal)))))) (when (and (slot-boundp item 'keystroke) - (slot-value item 'keystroke)) + (slot-value item 'keystroke)) (%add-keystroke-item command-table (slot-value item 'keystroke) item nil)))

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 15 Apr '08

15 Apr '08

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv26788 Modified Files: stream-output.lisp Log Message: Fixed output bug where :end-of-line-action is :wrap and there isn't room for even a single character. Acts as :allow in this case, would infinitely recurse previously. --- /project/mcclim/cvsroot/mcclim/stream-output.lisp 2006/12/10 23:35:12 1.61 +++ /project/mcclim/cvsroot/mcclim/stream-output.lisp 2008/04/15 19:28:04 1.62 @@ -305,7 +305,10 @@ (when (>= (+ cx width) margin) (ecase (stream-end-of-line-action stream) (:wrap - (setq split (find-split (- margin cx)))) + ;; Let's prevent infinite recursion if there isn't + ;; room for even a single character. + (setq split (max (find-split (- margin cx)) + (1+ start)))) (:scroll (scroll-horizontal stream width)) (:allow)))

1 0

[mcclim-cvs] CVS mcclim/Examples
by thenriksen 15 Apr '08

15 Apr '08

Update of /project/mcclim/cvsroot/mcclim/Examples In directory clnet:/tmp/cvs-serv10125/Examples Modified Files: image-viewer.lisp Log Message: Improved the image-viewer demo. --- /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/14 16:46:28 1.1 +++ /project/mcclim/cvsroot/mcclim/Examples/image-viewer.lisp 2008/04/15 10:19:21 1.2 @@ -43,17 +43,23 @@ ;; Clear the old image. (with-bounding-rectangle* (x1 y1 x2 y2) (sheet-region pane) (draw-rectangle* (sheet-medium pane) x1 y1 x2 y2 :ink +background-ink+)) + ;; Draw the new one, if there is one. (when (gadget-value pane) - ;; Try to ensure there is room for the new image. - (change-space-requirements pane - :height (pattern-height (gadget-value pane)) - :width (pattern-width (gadget-value pane))) - ;; Draw the new one, if there is one. - (handler-case (draw-pattern* pane (gadget-value pane) 0 0) - (error () - (with-text-style (pane (make-text-style nil :italic nil)) - (draw-text* pane (format nil "Error while drawing image") - 0 0 :align-y :top)))))) + (let ((image-height (pattern-height (gadget-value pane))) + (image-width (pattern-width (gadget-value pane)))) + ;; Try to ensure there is room for the new image. + (change-space-requirements pane :height image-height :width image-width) + ;; Draw it in the center. + (handler-case (draw-pattern* + pane (gadget-value pane) + (/ (- (bounding-rectangle-width pane) image-width) + 2) + (/ (- (bounding-rectangle-height pane) image-height) + 2)) + (error () + (with-text-style (pane (make-text-style nil :italic nil)) + (draw-text* pane (format nil "Error while drawing image") + 0 0 :align-y :top))))))) (define-application-frame image-viewer () ((%image-pathname :accessor image-pathname @@ -93,6 +99,10 @@ (format t "Image format ~A not recognized" type)))) (format t "No such file: ~A" image-pathname))) +(define-image-viewer-command (com-blank-image :name t :menu t) + () + (setf (gadget-value (find-pane-named *application-frame* 'viewer)) nil)) + (defun image-viewer (&key (new-process t)) (flet ((run () (let ((frame (make-application-frame 'image-viewer)))

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs