From thenriksen at common-lisp.net Thu May 1 06:48:22 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 May 2008 02:48:22 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080501064822.6CDE753196@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv25657/Drei Modified Files: drei-clim.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/04/30 21:27:46 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2008/05/01 06:48:21 1.45 @@ -229,7 +229,8 @@ ;;; updating is done after a command has been executed, and only then ;;; (or by commands at their own discretion). (defclass drei-gadget-pane (drei-pane value-gadget action-gadget - asynchronous-command-processor) + asynchronous-command-processor + dead-key-merging-command-processor) ((%currently-processing :initform nil :accessor currently-processing-p) (%previous-focus :accessor previous-focus :initform nil @@ -296,12 +297,11 @@ (*abort-gestures* *esa-abort-gestures*) (*standard-input* drei)) (accepting-from-user (drei) - (handling-dead-keys (gesture) - (handler-case (process-gesture drei gesture) - (unbound-gesture-sequence (c) - (display-message "~A is unbound" (gesture-name (gestures c)))) - (abort-gesture () - (display-message "Aborted")))) + (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 :redisplay-minibuffer t) (when (modified-p (view drei)) (when (gadget-value-changed-callback drei) From thenriksen at common-lisp.net Thu May 1 06:48:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 May 2008 02:48:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080501064823.49B0153196@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv25657/ESA Modified Files: esa.lisp packages.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/04/30 21:27:46 1.22 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/01 06:48:22 1.23 @@ -501,6 +501,18 @@ (setf (accumulated-gestures command-processor) nil) (signal 'abort-gesture :event gesture))) +(defclass dead-key-merging-command-processor (command-processor) + ((%dead-key-state :accessor dead-key-state + :initform nil + :documentation "The state of dead key +handling as per `merging-dead-keys'.")) + (:documentation "Helper class useful for asynchronous command +processors, merges incoming dead keys with the following key.")) + +(defmethod process-gesture :around ((command-processor dead-key-merging-command-processor) gesture) + (merging-dead-keys (gesture (dead-key-state command-processor)) + (call-next-method command-processor gesture))) + (defclass command-loop-command-processor (command-processor) ((%command-table :reader command-table :initarg :command-table --- /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/04/29 20:52:05 1.19 +++ /project/mcclim/cvsroot/mcclim/ESA/packages.lisp 2008/05/01 06:48:22 1.20 @@ -65,7 +65,7 @@ #:add-default-modes #:remove-default-modes)) (defpackage :esa - (:use :clim-lisp :clim :esa-utils) + (:use :clim-lisp :clim :esa-utils :clim-extensions) (:export #:*esa-instance* #:buffers #:esa-current-buffer #:current-buffer #:windows #:esa-current-window #:current-window @@ -79,6 +79,7 @@ #:unbound-gesture-sequence #:gestures #:command-processor #:instant-macro-execution-mixin #:asynchronous-command-processor #:command-loop-command-processor + #:dead-key-merging-command-processor #:overriding-handler #:directly-processing-p #:process-gesture #:process-gestures-or-command #:command-for-unbound-gestures #:*extended-command-prompt* @@ -89,7 +90,6 @@ #:find-applicable-command-table #:esa-command-parser #:esa-partial-command-parser - #:handling-dead-keys #:gesture-matches-gesture-name-p #:meta-digit #:proper-gesture-p From thenriksen at common-lisp.net Thu May 1 06:48:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 May 2008 02:48:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080501064823.9B7FC59092@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv25657 Modified Files: dead-keys.lisp package.lisp Log Message: Wrap up the last dead-key stuff for Drei gadgets. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/04/30 21:27:48 1.1 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 06:48:23 1.2 @@ -113,3 +113,35 @@ (define-dead-key-combination (code-char 251) (:dead-circumflex #\u)) (define-dead-key-combination (code-char 94) (:dead-circumflex #\space)) (define-dead-key-combination (code-char 94) (:dead-circumflex :dead-circumflex)) + +(defmacro merging-dead-keys ((gesture state) &body body) + "Accumulate dead keys and subsequent characters. `Gesture' +should be a symbol bound to either a gesture or an input +event. When it has been determined that a sequence of `gesture's +either does or doesn't result in a full gesture, `body' will be +evaluated with `gesture' bound to that gesture. `State' must be a +place, initially NIL, that will contain the state of dead-key +handling, enabling asynchronous use of the macro." + `(flet ((invoke-body (,gesture) + (setf ,state *dead-key-table*) + , at body)) + (when (null ,state) + (setf ,state *dead-key-table*)) + (if (typep ,gesture '(or keyboard-event character)) + (let ((value (gethash (if (characterp ,gesture) + ,gesture + (keyboard-event-key-name ,gesture)) + ,state))) + (etypecase value + (null + (cond ((eq ,state *dead-key-table*) + (invoke-body ,gesture)) + ((or (and (typep ,gesture 'keyboard-event) + (keyboard-event-character ,gesture)) + (characterp ,gesture)) + (setf ,state *dead-key-table*)))) + (character + (invoke-body value)) + (hash-table + (setf ,state value)))) + (invoke-body ,gesture)))) --- /project/mcclim/cvsroot/mcclim/package.lisp 2008/04/14 16:46:38 1.68 +++ /project/mcclim/cvsroot/mcclim/package.lisp 2008/05/01 06:48:23 1.69 @@ -1945,6 +1945,7 @@ #:frame-display-pointer-documentation-string #:list-pane-items #:output-record-baseline + #:merging-dead-keys #:draw-output-border-over #:draw-output-border-under From thenriksen at common-lisp.net Thu May 1 07:48:46 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 May 2008 03:48:46 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080501074846.A3B187C04C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv9480 Modified Files: dead-keys.lisp stream-input.lisp Log Message: Removed some code duplication in dead key handling. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 06:48:23 1.2 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 07:48:45 1.3 @@ -117,13 +117,12 @@ (defmacro merging-dead-keys ((gesture state) &body body) "Accumulate dead keys and subsequent characters. `Gesture' should be a symbol bound to either a gesture or an input -event. When it has been determined that a sequence of `gesture's -either does or doesn't result in a full gesture, `body' will be -evaluated with `gesture' bound to that gesture. `State' must be a -place, initially NIL, that will contain the state of dead-key -handling, enabling asynchronous use of the macro." +event. `Body' will be evaluated either with the `gesture' binding +unchanged, or with `gesture' bound to the result of merging +preceding dead keys. `State' must be a place, initially NIL, that +will contain the state of dead-key handling, enabling +asynchronous use of the macro." `(flet ((invoke-body (,gesture) - (setf ,state *dead-key-table*) , at body)) (when (null ,state) (setf ,state *dead-key-table*)) @@ -141,7 +140,10 @@ (characterp ,gesture)) (setf ,state *dead-key-table*)))) (character + (setf ,state *dead-key-table*) (invoke-body value)) (hash-table - (setf ,state value)))) - (invoke-body ,gesture)))) + (setf ,state value) + (invoke-body value)))) + (progn (setf ,state *dead-key-table*) + (invoke-body ,gesture))))) --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/04/30 21:27:48 1.52 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 07:48:45 1.53 @@ -146,37 +146,23 @@ (handler-case (loop with start-time = (get-internal-real-time) with end-time = start-time - for gesture = (call-next-method stream - :timeout (when timeout - (- timeout (/ (- end-time start-time) - internal-time-units-per-second))) - :peek-p peek-p - :input-wait-test input-wait-test - :input-wait-handler input-wait-handler - :pointer-button-press-handler - pointer-button-press-handler) - do (setf end-time (get-internal-real-time) - last-deadie-gesture gesture - last-state state) - do (if (typep gesture '(or keyboard-event character)) - (let ((value (gethash (if (characterp gesture) - gesture - (keyboard-event-key-name gesture)) - state))) - (etypecase value - (null - (cond ((eq state *dead-key-table*) - (return gesture)) - ((or (and (typep gesture 'keyboard-event) - (keyboard-event-character gesture)) - (characterp gesture)) - (setf state *dead-key-table*)))) - (character - (setf state *dead-key-table*) - (return value)) - (hash-table - (return (setf state value))))) - (return gesture))) + do (multiple-value-bind (gesture reason) + (call-next-method stream + :timeout (when timeout + (- timeout (/ (- end-time start-time) + internal-time-units-per-second))) + :peek-p peek-p + :input-wait-test input-wait-test + :input-wait-handler input-wait-handler + :pointer-button-press-handler + pointer-button-press-handler) + (when (null gesture) + (return (values nil reason))) + (setf end-time (get-internal-real-time) + last-deadie-gesture gesture + last-state state) + (merging-dead-keys (gesture state) + (return gesture)))) ;; Policy decision: an abort cancels the current composition. (abort-gesture (c) (setf state *dead-key-table*) From thenriksen at common-lisp.net Thu May 1 21:45:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 1 May 2008 17:45:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080501214523.DCBCC7114C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3732 Modified Files: dead-keys.lisp mcclim.asd stream-input.lisp Log Message: Fix compile dependencies. --- /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 07:48:45 1.3 +++ /project/mcclim/cvsroot/mcclim/dead-keys.lisp 2008/05/01 21:45:23 1.4 @@ -23,6 +23,10 @@ (in-package :clim-internals) +(defvar *dead-key-table* (make-hash-table :test 'equal) + "A hash table mapping keyboard event names and characters to +either a similar hash table or characters.") + (defun set-dead-key-combination (character gestures table) "Set `gestures' to result in `character' in the hash table `table' (see `*dead-key-table*' for the format of the hash --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/04/30 21:27:48 1.82 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/01 21:45:23 1.83 @@ -140,6 +140,7 @@ (:file "coordinates" :depends-on ("decls" "protocol-classes" "Lisp-Dep")) (:file "setf-star" :depends-on ("decls" "Lisp-Dep")) (:file "transforms" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils")) + (:file "dead-keys" :depends-on ("decls")) (:file "regions" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star" "design")) (:file "sheets" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "utils" "transforms" "regions")) (:file "pixmap" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "transforms" "regions")) @@ -163,8 +164,7 @@ (:file "encapsulate" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "sheets" "graphics" "utils" "medium" "input" "stream-output" "recording")) (:file "stream-input" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "input" "ports" "sheets" "events" - "encapsulate" "transforms" "utils")) - (:file "dead-keys" :depends-on ("stream-input")) + "encapsulate" "transforms" "utils" "dead-keys")) (:file "text-selection" :depends-on ("decls" "protocol-classes" "Lisp-Dep" "X11-colors" "medium" "output" "transforms" "sheets" "stream-output" "ports" "recording" "regions" --- /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 07:48:45 1.53 +++ /project/mcclim/cvsroot/mcclim/stream-input.lisp 2008/05/01 21:45:23 1.54 @@ -122,10 +122,6 @@ do (handle-event (event-sheet event) event)) nil) -(defvar *dead-key-table* (make-hash-table :test 'equal) - "A hash table mapping keyboard event names and characters to -either a similar hash table or characters.") - (defclass dead-key-merging-mixin () ((state :initform *dead-key-table*) (last-deadie-gesture) ; For avoiding name clash with standard-extended-input-stream From thenriksen at common-lisp.net Sat May 3 07:47:17 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 May 2008 03:47:17 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080503074717.C61CF37014@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv13626/Drei Modified Files: drei-redisplay.lisp views.lisp Log Message: Moved defvar to remove warnings. --- /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/04/15 09:19:43 1.70 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-redisplay.lisp 2008/05/03 07:47:17 1.71 @@ -745,11 +745,6 @@ (when (> old-height (- y2 y1)) (clear-rectangle* pane x1 y2 (+ x1 old-width) (+ y1 old-height))))) -(defvar *maximum-chunk-size* 100 - "The maximum amount of objects put into a stroke by a -`drei-buffer-view'. Actual strokes may be smaller if a #\Newline -character is encountered.") - (defun object-drawer () "Return a closure capable of functioning as a stroke drawer. It expects its stroke to cover a single-object non-character buffer --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/03/07 15:23:14 1.44 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/03 07:47:17 1.45 @@ -719,6 +719,11 @@ "Return the length of the `buffer-line' object `line'." (- (end-offset line) (start-offset line))) +(defvar *maximum-chunk-size* 100 + "The maximum amount of objects put into a single chunk by a +`drei-buffer-view'. Actual chunks may be smaller if a #\Newline +character is encountered.") + (defun get-chunk (buffer line-start-offset chunk-start-offset line-end-offset) "Return a chunk in the form of a cons cell. The chunk will start at `chunk-start-offset' and extend no further than From thenriksen at common-lisp.net Sat May 3 08:48:04 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 May 2008 04:48:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080503084804.1D6C068004@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv27957/Drei Modified Files: lisp-syntax-swine.lisp Log Message: Minor fixes to complete-symbol-at-mark-with-fn. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/02/18 10:45:26 1.18 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2008/05/03 08:48:03 1.19 @@ -841,8 +841,8 @@ be displayed. If no symbol can be found at `mark', return NIL. If there is no symbol at `mark' and `complete-blank' is true (the default), all symbols available in the current package will be -shown. If `complete-blank' is true, nothing will be shown and the -function will return NIL." +shown. If `complete-blank' is false, nothing will be shown and +the function will return NIL." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) @@ -870,7 +870,8 @@ syntax mark (or (when (or useful-token (accept 'boolean - :prompt "You are asking for a list of all exported symbols, proceed?")) + :prompt "You are asking for a list of all exported symbols, proceed?") + (return-from complete-symbol-at-mark-with-fn nil)) (frame-manager-menu-choose (find-frame-manager) (mapcar From thenriksen at common-lisp.net Sat May 3 09:12:26 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 3 May 2008 05:12:26 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080503091226.25D2947143@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv1637/Drei Modified Files: lisp-syntax.lisp packages.lisp Log Message: Some generalisations in Lisp syntax. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/03/02 15:55:28 1.76 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/03 09:12:25 1.77 @@ -1420,18 +1420,23 @@ `mark-or-offset' is returned." (form-toplevel syntax (expression-at-mark syntax mark-or-offset))) -(defun list-at-mark (syntax mark-or-offset) - "Return the list form that `mark-or-offset' is inside, or NIL -if no such form exists." +(defun form-of-type-at-mark (syntax mark-or-offset test) + "Return the form that `mark-or-offset' is inside and for which +`test' returns true, or NIL if no such form exists." (as-offsets ((offset mark-or-offset)) (update-parse syntax) (let ((form-around (form-around syntax offset))) (when form-around - (if (and (form-list-p form-around) + (if (and (funcall test form-around) (> offset (start-offset form-around))) form-around (find-list-parent form-around)))))) +(defun list-at-mark (syntax mark-or-offset) + "Return the list form that `mark-or-offset' is inside, or NIL +if no such form exists." + (form-of-type-at-mark syntax mark-or-offset #'form-list-p)) + (defun symbol-at-mark (syntax mark-or-offset &optional (form-fetcher 'expression-at-mark)) "Return a symbol token at `mark-or-offset'. This function will @@ -2044,41 +2049,67 @@ nil (form-around-in-children syntax (children stack-top) offset)))))) +(defun find-parent-of-type (form test) + "Find a parent of `form' for which the function `test' is true +and return it. If a such a parent cannot be found, return nil." + (let ((parent (parent form))) + (cond ((null parent) + nil) + ((funcall test parent) + parent) + (t (find-parent-of-type parent test))))) + +(defun find-parent-of-type-offset (form test fn) + "Find a parent of `form' for which the function `test' is true +and return `fn' applied to this parent form. `Fn' should be a +function that returns an offset when applied to a +form (eg. `start-offset' or `end-offset'). If such a parent +cannot be found, return nil" + (let ((parent (find-parent-of-type form test))) + (when parent + (funcall fn parent)))) + +(defun find-child-of-type (form test) + "Find the first child of `form' for which the function `test' +is true and return it. If such a child cannot be found, return +nil." + (find-if #'(lambda (child) + (cond ((funcall test child) child) + ((formp child) (find-child-of-type child test)))) + (children form))) + +(defun find-child-of-type-offset (form test fn) + "Find the first child of `form' for which the function `test' is true and return `fn' applied to this child. +`Fn' should be a function that returns an offset when applied to +a form (eg. `start-offset' or `end-offset'). If such a child +cannot be found, return nil." + (let ((child (find-child-of-type form test))) + (when child + (funcall fn child)))) + (defun find-list-parent (form) "Find a list parent of `form' and return it. If a list parent cannot be found, return nil." - (let ((parent (parent form))) - (typecase parent - (list-form parent) - ((or form* null) nil) - (t (find-list-parent parent))))) + (find-parent-of-type form #'form-list-p)) (defun find-list-parent-offset (form fn) "Find a list parent of `form' and return `fn' applied to this parent token. `Fn' should be a function that returns an offset when applied to a token (eg. `start-offset' or `end-offset'). If a list parent cannot be found, return nil" - (let ((list-parent (find-list-parent form))) - (when list-parent - (funcall fn list-parent)))) + (find-parent-of-type-offset form #'form-list-p fn)) (defun find-list-child (form) "Find the first list child of `form' and return it. If a list child cannot be found, return nil." - (find-if #'(lambda (child) - (typecase child - (list-form child) - (form (find-list-child child)))) - (children form))) + (find-child-of-type form #'form-list-p)) (defun find-list-child-offset (form fn) "Find a list child of `form' and return `fn' applied to this child. `Fn' should be a function that returns an offset when applied to a form (eg. `start-offset' or `end-offset'). If a list child cannot be found, return nil." - (let ((list-child (find-list-child form))) - (when list-child - (funcall fn list-child)))) + (find-child-of-type-offset form #'form-list-p fn)) (defmethod backward-one-expression (mark (syntax lisp-syntax)) (update-parse syntax 0 (offset mark)) --- /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/02/15 13:16:17 1.53 +++ /project/mcclim/cvsroot/mcclim/Drei/packages.lisp 2008/05/03 09:12:25 1.54 @@ -562,6 +562,7 @@ #:find-list-parent #:expression-at-mark #:definition-at-mark + #:form-of-type-at-mark #:list-at-mark #:symbol-at-mark #:fully-quoted-form From ahefner at common-lisp.net Tue May 6 20:47:30 2008 From: ahefner at common-lisp.net (ahefner) Date: Tue, 6 May 2008 16:47:30 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20080506204730.E31B33F01A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv27864 Modified Files: pixie.lisp Log Message: Text style trickery - with truetype fonts, for whatever reason, :small feels much smaller. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2007/03/20 01:51:22 1.21 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:47:30 1.22 @@ -1170,7 +1170,11 @@ (:default-initargs :default-view +pixie-tab-bar-view+ :background +gray83+ - :text-style (make-text-style :sans-serif :roman :small))) + :text-style (make-text-style :sans-serif + :roman + (if (find-package :mcclim-truetype) + :normal + :small)))) (defmethod compose-space ((pane pixie-tab-bar-pane) &key width height) (declare (ignore width height)) From ahefner at common-lisp.net Tue May 6 20:49:04 2008 From: ahefner at common-lisp.net (ahefner) Date: Tue, 6 May 2008 16:49:04 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Looks Message-ID: <20080506204904.183EF450CD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Looks In directory clnet:/tmp/cvs-serv28102 Modified Files: pixie.lisp Log Message: Applied patch from Clinton Ebadi to call value-changed callback of slider. --- /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:47:30 1.22 +++ /project/mcclim/cvsroot/mcclim/Looks/pixie.lisp 2008/05/06 20:49:02 1.23 @@ -268,6 +268,13 @@ (defmethod handle-event ((pane pixie-slider-pane) (event pointer-button-release-event)) (with-slots (armed dragging value bounce-value repeating was-repeating) pane (setf was-repeating repeating) + (when armed + (setf armed t + (gadget-value pane :invoke-callback t) + (convert-position-to-value pane + (if (eq (gadget-orientation pane) :vertical) + (pointer-event-y event) + (pointer-event-x event))))) (when dragging (unless (eq dragging :inside) (setf armed nil From thenriksen at common-lisp.net Fri May 9 19:12:14 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 9 May 2008 15:12:14 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080509191214.7293D702EF@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv1766 Modified Files: gadgets.lisp panes.lisp Log Message: Specify :orientation default initarg for radio button gadgets. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/02/19 22:26:06 1.108 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 19:12:14 1.109 @@ -550,7 +550,8 @@ () (:documentation "The value is a list of buttons") (:default-initargs - :value nil)) + :value nil + :orientation :vertical)) ;; CHECK-BOX-CURRENT-SELECTION is just a synonym for GADGET-VALUE: --- /project/mcclim/cvsroot/mcclim/panes.lisp 2008/01/30 21:21:44 1.189 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2008/05/09 19:12:14 1.190 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.189 2008/01/30 21:21:44 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.190 2008/05/09 19:12:14 thenriksen Exp $ (in-package :clim-internals) @@ -1074,6 +1074,7 @@ ((box-layout-orientation :initarg :box-layout-orientation :initform :vertical + :type (member :vertical :horizontal) :accessor box-layout-orientation)) (:documentation "Mixin class for layout panes, which want to behave like a HRACK/VRACK.")) From thenriksen at common-lisp.net Fri May 9 21:24:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 9 May 2008 17:24:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080509212428.60C2364042@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv31790 Modified Files: gadgets.lisp Log Message: Fix list panes with multi-element-selection. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 19:12:14 1.109 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 21:24:28 1.110 @@ -1976,15 +1976,18 @@ (> (length (gadget-value gadget)) 1)) (error "An 'exclusive' list-pane cannot be initialized with more than one item selected."))) -(defmethod value-changed-callback - :before +(defmethod value-changed-callback :before ((gadget generic-list-pane) client gadget-id value) (declare (ignore client gadget-id)) - (let* ((i (position value (generic-list-pane-item-values gadget))) - (item (elt (list-pane-items gadget) i)) - (ptype (funcall (list-pane-presentation-type-key gadget) item))) - (when ptype - (throw-object-ptype value ptype)))) + ;; Maybe act as if a presentation was clicked on, but only if the + ;; list pane only allows single-selection. + (when (or (eq (list-pane-mode gadget) :one-of) + (eq (list-pane-mode gadget) :exclusive)) + (let* ((i (position value (generic-list-pane-item-values gadget))) + (item (elt (list-pane-items gadget) i)) + (ptype (funcall (list-pane-presentation-type-key gadget) item))) + (when ptype + (throw-object-ptype value ptype))))) (defun list-pane-exclusive-p (pane) (or (eql (list-pane-mode pane) :exclusive) From thenriksen at common-lisp.net Fri May 9 22:16:11 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Fri, 9 May 2008 18:16:11 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080509221611.9BB98601C6@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv10826 Modified Files: gadgets.lisp Log Message: The default value of a list-pane should be NIL. --- /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 21:24:28 1.110 +++ /project/mcclim/cvsroot/mcclim/gadgets.lisp 2008/05/09 22:16:11 1.111 @@ -628,7 +628,8 @@ (:documentation "The instantiable class that implements an abstract list pane, that is, a gadget whose semantics are similar to a radio box or check box, but whose visual - appearance is a list of buttons.")) + appearance is a list of buttons.") + (:default-initargs :value nil)) (defclass option-pane (value-gadget) () From ahefner at common-lisp.net Tue May 13 03:04:39 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 12 May 2008 23:04:39 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080513030439.0E5052510F@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv15466 Modified Files: sheets.lisp Log Message: clim:graft should return nil for degrafted sheets. Also, strengthen conditions necessary to process configure-notify for toplevel sheets. This should reduce or eliminate 'No applicable method for generic funciton clim:graft with arguments NIL' errors when closing the listener, due to a race condition between disown-frame and the CLX event thread. --- /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/01/21 01:26:42 1.55 +++ /project/mcclim/cvsroot/mcclim/sheets.lisp 2008/05/13 03:04:37 1.56 @@ -448,7 +448,7 @@ (bury-mirror (port sheet) sheet))) (defmethod graft ((sheet sheet-parent-mixin)) - (graft (sheet-parent sheet))) + (and (sheet-parent sheet) (graft (sheet-parent sheet)))) (defmethod (setf sheet-transformation) :after (newvalue (sheet sheet-parent-mixin)) (declare (ignore newvalue)) From ahefner at common-lisp.net Tue May 13 03:04:39 2008 From: ahefner at common-lisp.net (ahefner) Date: Mon, 12 May 2008 23:04:39 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/CLX Message-ID: <20080513030439.62E9525115@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory clnet:/tmp/cvs-serv15466/Backends/CLX Modified Files: port.lisp Log Message: clim:graft should return nil for degrafted sheets. Also, strengthen conditions necessary to process configure-notify for toplevel sheets. This should reduce or eliminate 'No applicable method for generic funciton clim:graft with arguments NIL' errors when closing the listener, due to a race condition between disown-frame and the CLX event thread. --- /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/01/21 01:07:49 1.133 +++ /project/mcclim/cvsroot/mcclim/Backends/CLX/port.lisp 2008/05/13 03:04:39 1.134 @@ -743,8 +743,8 @@ :timestamp time)) ;; (:configure-notify - ;; Resizes are consolidated later.. --Hefner (cond ((and (eq (sheet-parent sheet) (graft sheet)) + (graft sheet) (not override-redirect-p) (not send-event-p)) ;; this is genuine event for a top-level sheet (with From thenriksen at common-lisp.net Thu May 15 13:51:41 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 15 May 2008 09:51:41 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080515135141.B52265D088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv21582/Drei Modified Files: views.lisp Log Message: Delete the line cache when changing the buffer of a Drei buffer view. --- /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/03 07:47:17 1.45 +++ /project/mcclim/cvsroot/mcclim/Drei/views.lisp 2008/05/15 13:51:40 1.46 @@ -645,7 +645,7 @@ (defmethod (setf buffer) :after (buffer (view drei-buffer-view)) (invalidate-all-strokes view) - (with-accessors ((top top) (bot bot) + (with-accessors ((top top) (bot bot) (lines lines) (lines-prefix lines-prefix-size) (lines-suffix lines-suffix-size) (buffer-size last-seen-buffer-size)) view @@ -654,6 +654,7 @@ lines-prefix 0 lines-suffix 0 buffer-size 0) + (delete-elements* lines 0 (nb-elements lines)) (update-line-data view))) (defmethod cache-string :around ((view drei-buffer-view)) From thenriksen at common-lisp.net Thu May 15 16:08:00 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 15 May 2008 12:08:00 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080515160800.39B5B232BD@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv7688 Modified Files: text-formatting.lisp Log Message: FILLING-OUTPUT fixes: * Very naive and inefficient implementation of STREAM-WRITE-STRING. * Silenced compiler warning. --- /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2006/03/29 10:43:37 1.9 +++ /project/mcclim/cvsroot/mcclim/text-formatting.lisp 2008/05/15 16:07:59 1.10 @@ -80,13 +80,17 @@ (encapsulating-stream-stream stream)))) (call-next-method)))) +(defmethod stream-write-string :around ((stream filling-stream) string + &optional (start 0) (end (length string))) + (dotimes (i (- end start)) + (stream-write-char stream (aref string (+ i start))))) + ;;; All the monkey business with the lambda form has to do with capturing the ;;; keyword arguments of the macro while preserving the user's evaluation order. (defmacro filling-output ((stream &rest args &key fill-width break-characters after-line-break after-line-break-initially) &body body) - (declare (ignore after-line-break-initially)) (when (eq stream t) (setq stream '*standard-output*)) (with-gensyms (fill-var break-var after-var initially-var) @@ -94,7 +98,7 @@ ((:break-characters ,break-var)) ((:after-line-break ,after-var)) ((:after-line-break-initially ,initially-var))) - (declare (ignorable ,fill-var ,break-var ,after-var)) + (declare (ignorable ,fill-var ,break-var ,after-var ,initially-var)) (let ((,stream (make-instance 'filling-stream :stream ,stream @@ -103,8 +107,9 @@ `(:break-characters ,break-var)) ,@(and after-line-break `(:after-line-break ,after-var))))) - (when ,initially-var - (write-string ,after-var ,stream)) + ,(unless (null after-line-break-initially) + `(when ,initially-var + (write-string ,after-var ,stream))) , at body)) , at args))) From rschlatte at common-lisp.net Fri May 16 14:05:09 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:09 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080516140509.64A014F109@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3307 Modified Files: mcclim.asd Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/01 21:45:23 1.83 +++ /project/mcclim/cvsroot/mcclim/mcclim.asd 2008/05/16 14:05:07 1.84 @@ -82,11 +82,9 @@ (defsystem :clx :class requireable-system)) -;;; Required for the beagle backend (not activated by default) +;;; Clozure CL native GUI stuff #+clim-beagle -(progn - (require :cocoa) - (require :objc-support)) +(require :cocoa) (defmacro clim-defsystem ((module &key depends-on) &rest components) `(progn @@ -405,6 +403,7 @@ :serial t :components ((:file "package") + (:file "cocoa-util") (:module "native" :components ((:file "lisp-bezier-path") (:file "lisp-window") @@ -417,7 +416,6 @@ (:file "lisp-slider") (:file "lisp-button") (:file "lisp-image"))) - (:file "cocoa-util") (:module "windowing" :depends-on ("native") :components ((:file "port") From rschlatte at common-lisp.net Fri May 16 14:05:11 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:11 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle Message-ID: <20080516140511.83ACC5003A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory clnet:/tmp/cvs-serv3307/Backends/beagle Modified Files: cocoa-util.lisp package.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/cocoa-util.lisp 2005/06/05 19:52:54 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/cocoa-util.lisp 2008/05/16 14:05:09 1.5 @@ -23,30 +23,33 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -(in-package :ccl) +(in-package :beagle) + +(declaim (inline cg-floatify)) +(defun cg-floatify (cg-float-value) + (float cg-float-value ns:+cgfloat-zero+)) -;; Make an NSRect structure with the origin at (x, y) and with the width and height -;; specified. (defun make-ns-rect (x y width height) "Make a Cocoa NSRect structure with the origin at (x, y) and with the width and height specified. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :ect :origin.x x - :origin.y y - :size.width width - :size.height height)) + (ccl:make-record :ect + :origin.x (cg-floatify x) + :origin.y (cg-floatify y) + :size.width (cg-floatify width) + :size.height (cg-floatify height))) (defun make-ns-point (x y) "Make a Cocoa NSPoint structure populated with x and y provided. The memory for any structure created with this method must be released by the user (using (#_free))." - (make-record :oint :x x :y y)) + (ccl:make-record :oint :x (cg-floatify x) :y (cg-floatify y))) ;; Stolen from Bosco "main.lisp". (defun description (c) - (with-autorelease-pool - (lisp-string-from-nsstring - (send c 'description)))) + (ccl::with-autorelease-pool + (ccl::lisp-string-from-nsstring + (ccl::send c 'description)))) (defun nslog (c) (let* ((rep (format nil "~a" c))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2007/12/18 10:54:21 1.6 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/package.lisp 2008/05/16 14:05:09 1.7 @@ -1,18 +1,5 @@ ;;; -*- Mode: Lisp; Package: COMMON-LISP-USER -*- -(eval-when (:compile-toplevel :load-toplevel :execute) - (require :cocoa)) - -;;; START - Cribbed from framework/cocoa-support.lisp -(in-package "CCL") -(defun nslog (c) - "Writes a string message to the OSX console log." - (let* ((rep (format nil "~a" c))) - (with-cstrs ((str rep)) - (with-nsstr (nsstr str (length rep)) - (#_NSLog #@"Logging: %@" :address nsstr))))) -;;; END - (in-package :common-lisp-user) (defpackage :beagle @@ -84,11 +71,9 @@ (:import-from :ccl #:@class #:define-objc-method - #:description #:get-selector-for #:make-cstring #:%make-nsstring - #:nslog #:ns-make-point #:%null-ptr #:pref From rschlatte at common-lisp.net Fri May 16 14:05:13 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:13 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/native Message-ID: <20080516140513.9B3235D183@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native Modified Files: lisp-bezier-path.lisp lisp-image.lisp lisp-view.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-bezier-path.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-bezier-path.lisp 2008/05/16 14:05:11 1.2 @@ -28,7 +28,7 @@ (defclass lisp-bezier-path (ns:ns-bezier-path) ((colour :foreign-type :id :accessor path-colour) - (fill :foreign-type :bool + (fill :foreign-type : :initform #$NO :accessor path-fill)) (:metaclass ns:+ns-object)) @@ -36,7 +36,7 @@ (define-objc-method ((:void :set-colour colour) lisp-bezier-path) (setf (path-colour self) colour)) -(define-objc-method ((:void :set-fill (:bool fill)) lisp-bezier-path) +(define-objc-method ((:void :set-fill (: fill)) lisp-bezier-path) (setf (path-fill self) fill)) (define-objc-method ((:void draw) lisp-bezier-path) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2005/05/16 22:13:17 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-image.lisp 2008/05/16 14:05:11 1.2 @@ -129,7 +129,7 @@ (progn (send self 'lock-focus) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)))) ;;; (format *debug-io* "(paste-bitmap...) - FAILED TO LOCK FOCUS ON VIEW (NOT VALID) ~S!!!~%" self))) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2006/03/24 11:18:27 1.2 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native/lisp-view.lisp 2008/05/16 14:05:11 1.3 @@ -119,7 +119,7 @@ (when (send self 'lock-focus-if-can-draw) (let ((image (send (send (@class ns-image) 'alloc) :init-with-data (send bitmap "TIFFRepresentation")))) - (send image :dissolve-to-point point :fraction 1.0)) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0))) ;;; (send (send self 'window) 'flush-window) (send self 'unlock-focus)) ;;; (send (send self 'window) 'flush-window)) @@ -127,7 +127,7 @@ (define-objc-method ((:void :draw-image image :at-point (:oint point)) lisp-view) (when (send self 'lock-focus-if-can-draw) - (send image :dissolve-to-point point :fraction 1.0) + (send image :dissolve-to-point point :fraction #.(cg-floatify 1.0)) (send self 'unlock-focus))) ;;; ---------------------------------------------------------------------------- From rschlatte at common-lisp.net Fri May 16 14:05:23 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/native-panes Message-ID: <20080516140523.6741D13060@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes In directory clnet:/tmp/cvs-serv3307/Backends/beagle/native-panes Modified Files: beagle-fundamental-button-pane.lisp beagle-scroll-bar-pane.lisp beagle-slider-pane.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-fundamental-button-pane.lisp 2005/06/12 16:53:26 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-fundamental-button-pane.lisp 2008/05/16 14:05:15 1.2 @@ -77,10 +77,11 @@ (defun %beagle-get-label-size (label sheet) - (let ((retsize 0.0) + (let ((retsize (cg-floatify 0.0)) (dictionary (reuse-attribute-dictionary (sheet-medium sheet) (send (@class ns-font) - :system-font-of-size 0.0)))) + :system-font-of-size + (cg-floatify 0.0))))) (slet ((label-size (send (ccl::%make-nsstring label) :size-with-attributes dictionary))) (setf retsize label-size) @@ -100,12 +101,13 @@ (defmethod compose-space ((pb beagle-push-button-pane) &key width height) (declare (ignore width height)) ;; - magic numbers are from the HIG - (let ((column-spacing 12.0) - (row-spacing 12.0) - (standard-width-sans-ends 41.0) - (standard-end-size 28.0) - (standard-width 69.0) ; width of OK, Cancel buttons - (standard-height 20.0) + (let ((column-spacing #.(cg-floatify 12.0)) + (row-spacing #.(cg-floatify 12.0)) + (standard-width-sans-ends #.(cg-floatify 41.0)) + (standard-end-size #.(cg-floatify 28.0)) + ; width of OK, Cancel buttons + (standard-width #.(cg-floatify 69.0)) + (standard-height #.(cg-floatify 20.0)) (label-size (%beagle-get-label-size (gadget-label pb) pb))) (let ((width (if (< (pref label-size :ize.width) standard-width-sans-ends) standard-width-sans-ends @@ -125,10 +127,10 @@ (sheet beagle-push-button-pane)) (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-button :with-frame rect))) (send mirror 'retain) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2006/04/25 18:50:31 1.9 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-scroll-bar-pane.lisp 2008/05/16 14:05:17 1.10 @@ -21,10 +21,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (space-requirement-width q) - (space-requirement-height q))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-scroller :with-frame rect))) (send mirror 'retain) @@ -33,7 +33,7 @@ (send mirror :set-enabled #$YES) ;; Make knob fill pane initially. - (send mirror :set-float-value 0.0 :knob-proportion 1.0) + (send mirror :set-float-value 0.0 :knob-proportion #.(cg-floatify 1.0)) (setf (toolkit-object sheet) mirror) (setf (view-lisp-scroller mirror) sheet) @@ -99,7 +99,7 @@ (/ ts (+ range ts))))) (send (toolkit-object scroll-bar) :set-float-value (coerce (clamp value 0.0 1.0) 'short-float) - :knob-proportion (coerce (clamp loz-size 0.0 1.0) 'short-float)))) + :knob-proportion (cg-floatify (clamp loz-size 0.0 1.0))))) (defmethod (setf gadget-min-value) :after (new-value (pane beagle-scroll-bar-pane)) @@ -153,7 +153,7 @@ (/ size range)))) (send (toolkit-object gadget) :set-float-value (coerce position 'short-float) - :knob-proportion (coerce loz-size 'short-float))))) + :knob-proportion (cg-floatify loz-size))))) ;;; Called in the Cocoa App thread. --- /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2005/06/12 13:27:42 1.1 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/native-panes/beagle-slider-pane.lisp 2008/05/16 14:05:18 1.2 @@ -26,10 +26,10 @@ ;; bar; otherwise we get a :vertical bar. (let* ((q (compose-space sheet)) - (rect (ccl::make-ns-rect 0.0 - 0.0 - (coerce (space-requirement-width q) 'short-float) - (coerce (space-requirement-height q) 'short-float))) + (rect (make-ns-rect 0.0 + 0.0 + (space-requirement-width q) + (space-requirement-height q))) (mirror (make-instance 'lisp-slider :with-frame rect))) (send mirror 'retain) From rschlatte at common-lisp.net Fri May 16 14:05:27 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:27 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/output Message-ID: <20080516140527.EFDE3340CE@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/output In directory clnet:/tmp/cvs-serv3307/Backends/beagle/output Modified Files: fonts.lisp medium.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2007/12/18 10:54:22 1.4 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/fonts.lisp 2008/05/16 14:05:23 1.5 @@ -37,13 +37,13 @@ :serif "Times New Roman" :sans-serif "Verdana")) -(defparameter *beagle-text-sizes* '(:normal 12.0 - :tiny 9.0 - :very-small 10.0 - :small 11.0 - :large 14.0 - :very-large 18.0 - :huge 24.0)) +(defparameter *beagle-text-sizes* '(:normal #.(cg-floatify 12.0) + :tiny #.(cg-floatify 9.0) + :very-small #.(cg-floatify 10.0) + :small #.(cg-floatify 11.0) + :large #.(cg-floatify 14.0) + :very-large #.(cg-floatify 18.0) + :huge #.(cg-floatify 24.0))) (defparameter *beagle-native-fonts* (make-hash-table :test #'equal)) (defparameter *beagle-font-metrics* (make-hash-table :test #'equal)) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2006/03/29 10:43:38 1.5 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/output/medium.lisp 2008/05/16 14:05:23 1.6 @@ -84,7 +84,7 @@ (defmethod (setf medium-line-style) :before (line-style (medium beagle-medium)) (unless (equal (medium-line-style medium) line-style) - (let ((width (coerce (line-style-thickness line-style) 'short-float)) + (let ((width (cg-floatify (line-style-thickness line-style))) (cap (%translate-cap-shape (line-style-cap-shape line-style))) (dashes (line-style-dashes line-style)) (join (%translate-joint-shape (line-style-joint-shape line-style)))) @@ -344,7 +344,7 @@ (defmethod %clim-opacity-from-design ((medium beagle-medium) design) (declare (ignore medium design)) ;; Just a stub for now. ::FIXME:: Need to ask on the list about this... - 1.0) + #.(cg-floatify 1.0)) (defmethod %clim-colour-from-design ((medium beagle-medium) (design climi::indirect-ink)) @@ -477,12 +477,8 @@ (defun medium-copy-area-aux (from from-x from-y width height to to-x to-y) "Helper method for copying areas. 'from' and 'to' must both be 'mirror' objects. From and To coordinates must already be transformed as appropriate." - (let* ((source-region (ccl::make-ns-rect (coerce from-x 'short-float) - (coerce from-y 'short-float) - (coerce width 'short-float) - (coerce height 'short-float))) - (target-point (ccl::make-ns-point (coerce to-x 'short-float) - (coerce to-y 'short-float))) + (let* ((source-region (make-ns-rect from-x from-y width height)) + (target-point (make-ns-point to-x to-y)) (bitmap-image (send from :copy-bitmap-from-region source-region))) (when (eql bitmap-image (%null-ptr)) (warn "medium.lisp -> medium-copy-area: failed to copy specified region (null bitmap)~%") @@ -581,10 +577,10 @@ (do-sequence ((left top right bottom) coord-seq) (when (< right left) (rotatef left right)) (when (< top bottom) (rotatef top bottom)) - (let ((rect (ccl::make-ns-rect (pixel-center left) - (pixel-center bottom) - (pixel-count (- right left)) - (pixel-count (- top bottom))))) + (let ((rect (make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect) (#_free rect))) (if filled @@ -594,16 +590,15 @@ ;; ::FIXME:: Move these from here! (defun pixel-center (pt) "Ensure any ordinate provided sits on the center of a pixel. This -prevents Cocoa from 'antialiasing' lines, making them thicker and -a shade of grey. Ensures the return value is a short-float, as -required by the Cocoa methods." - (coerce (+ (round-coordinate pt) 0.5) 'short-float)) +prevents Cocoa from 'antialiasing' lines, making them thicker and a +shade of grey. Ensures the return value is an appropriate float type." + (cg-floatify (+ (round-coordinate pt) 0.5))) (defun pixel-count (sz) "Ensures any value provided is rounded to the nearest unit, and -returned as a short-float as required by the Cocoa methods." - (coerce (round-coordinate sz) 'short-float)) +returned as an appropriate float type." + (cg-floatify (round-coordinate sz))) ;;; Nabbed from CLX backend medium.lisp @@ -657,10 +652,10 @@ (origin-y (- center-y radius-dy)) (width (* 2 radius-dx)) (height (* 2 radius-dy)) - (rect (ccl::make-ns-rect (pixel-center origin-x) - (pixel-center origin-y) - (pixel-count width) - (pixel-count height)))) + (rect (make-ns-rect (pixel-center origin-x) + (pixel-center origin-y) + (pixel-count width) + (pixel-count height)))) (send path :append-bezier-path-with-oval-in-rect rect) (#_free rect) (if filled @@ -677,8 +672,8 @@ (pixel-center center-y)))) (send path :append-bezier-path-with-arc-with-center point :radius (pixel-count radius) - :start-angle (coerce (/ start-angle (/ pi 180)) 'short-float) - :end-angle (coerce (/ end-angle (/ pi 180)) 'short-float) + :start-angle (cg-floatify (/ start-angle (/ pi 180))) + :end-angle (cg-floatify (/ end-angle (/ pi 180))) :clockwise NIL))) (if filled (send mirror :fill-path path :in-colour colour) @@ -692,8 +687,7 @@ ;;; Draws a point on the medium 'medium'. (defmethod medium-draw-point* ((medium beagle-medium) x y) - (let ((width (coerce (line-style-thickness (medium-line-style medium)) - 'short-float))) + (let ((width (cg-floatify (line-style-thickness (medium-line-style medium))))) (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))) @@ -707,7 +701,7 @@ (defmethod medium-draw-points* ((medium beagle-medium) coord-seq) (with-transformed-positions ((sheet-native-transformation (medium-sheet medium)) coord-seq) - (let ((width (coerce (line-style-thickness (medium-line-style medium)) 'short-float))) + (let ((width (cg-floatify (line-style-thickness (medium-line-style medium))))) (do-sequence ((x y) coord-seq) (medium-draw-circle* medium x y (/ width 2) 0 (* 2 pi) t))))) @@ -775,10 +769,10 @@ (send mirror :draw-image colour :at-point (ns-make-point (pixel-center left) (pixel-center top))) (return-from medium-draw-rectangle* (values))) - (let ((rect (ccl::make-ns-rect (pixel-center left) - (pixel-center bottom) - (pixel-count (- right left)) - (pixel-count (- top bottom))))) + (let ((rect (make-ns-rect (pixel-center left) + (pixel-center bottom) + (pixel-count (- right left)) + (pixel-count (- top bottom))))) (send path :append-bezier-path-with-rect rect) (#_free rect) (if filled @@ -853,8 +847,7 @@ (:baseline (- y baseline)) ;;; (:bottom y))) (:bottom (- y text-height)))) - (slet ((point (ns-make-point (coerce x 'short-float) - (coerce y 'short-float)))) + (slet ((point (ns-make-point (cg-floatify x) (cg-floatify y)))) (let ((objc-string (%make-nsstring (subseq string start end)))) ;; NB: draw-string-at-point uses upper-left as origin in a flipped ;; view. From rschlatte at common-lisp.net Fri May 16 14:05:29 2008 From: rschlatte at common-lisp.net (rschlatte) Date: Fri, 16 May 2008 10:05:29 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Backends/beagle/windowing Message-ID: <20080516140529.659893700E@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing In directory clnet:/tmp/cvs-serv3307/Backends/beagle/windowing Modified Files: mirror.lisp port.lisp Log Message: Try to make beagle backend run both on 64-bit and 32-bit clozure cl * Only tested on 64-bit clozure cl 1.2rc1 * hacked until clim-listener runs; chances are I missed many 'short-floats * Also don't (re)define symbols in the ccl package --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2006/03/29 10:43:38 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/mirror.lisp 2008/05/16 14:05:27 1.8 @@ -235,8 +235,8 @@ (y 0) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (name (%make-nsstring (frame-pretty-name frame))) (top-level-frame (%beagle-make-window (beagle-port-screen port) rect @@ -266,8 +266,8 @@ (y 0) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (menu-frame (%beagle-make-window (beagle-port-screen port) rect :decorated nil)) (clim-mirror (make-instance 'lisp-view :with-frame rect))) (send clim-mirror 'retain) @@ -294,8 +294,8 @@ (q (compose-space sheet)) (width (space-requirement-width q)) (height (space-requirement-height q)) - (rect (ccl::make-ns-rect (pixel-center x) (pixel-center y) - (pixel-count width) (pixel-count height))) + (rect (make-ns-rect (pixel-center x) (pixel-center y) + (pixel-count width) (pixel-count height))) (mirror (make-instance view :with-frame rect))) (#_free rect) (send mirror 'retain) @@ -331,8 +331,8 @@ (defmethod realize-mirror ((port beagle-port) (pixmap pixmap)) (when (null (port-lookup-mirror port pixmap)) - (let* ((width (coerce (pixmap-width pixmap) 'short-float)) - (height (coerce (pixmap-height pixmap) 'short-float)) + (let* ((width (cg-floatify (pixmap-width pixmap))) + (height (cg-floatify (pixmap-height pixmap))) (mirror (make-instance 'lisp-image))) ;; :with-frame rect))) (send mirror 'retain) (slet ((size (ccl::ns-make-size width height))) @@ -432,9 +432,8 @@ ;; We've handled the frame (if necessary) - now resize the mirror itself. (slet ((frame-size (send mirror 'frame))) - (rlet ((size :ize :width (coerce (floor (bounding-rectangle-width mirror-region)) - 'short-float) - :height (coerce (floor (bounding-rectangle-height mirror-region)) 'short-float))) + (rlet ((size :ize :width (cg-floatify (floor (bounding-rectangle-width mirror-region))) + :height (cg-floatify (floor (bounding-rectangle-height mirror-region))))) ;; ignore this (for now) #+nil (when (and (equal (pref frame-size :ect.size.width) (pref size :ize.width)) @@ -448,9 +447,8 @@ (slet ((frame-rect (send mirror 'frame))) (rlet ((rect :ect :origin.x (pref frame-rect :ect.origin.x) :origin.y (pref frame-rect :ect.origin.y) - :size.width (coerce (floor (bounding-rectangle-width mirror-region)) 'short-float) - :size.height (coerce (floor (bounding-rectangle-height mirror-region)) - 'short-float))) + :size.width (cg-floatify (floor (bounding-rectangle-width mirror-region))) + :size.height (cg-floatify (floor (bounding-rectangle-height mirror-region))))) (send (send mirror 'window) :set-frame (send (send mirror 'window) :frame-rect-for-content-rect rect @@ -547,7 +545,7 @@ (let* ((app-tls (frame-top-level-sheet (pane-frame sheet))) (tls-mirror (port-lookup-mirror port app-tls)) (tls-window (send tls-mirror 'window)) - (origin-pt (ccl::make-ns-point 0.0 0.0))) + (origin-pt (make-ns-point 0.0 0.0))) (slet ((frame-pt (send tls-window :convert-base-to-screen origin-pt)) (tls-bounds (send tls-mirror 'bounds))) (#_free origin-pt) @@ -560,8 +558,7 @@ ;;; (setf y (+ y frame-y)) (setf y (- (+ frame-y tls-height) y))))))) - (let ((point (ccl::make-ns-point (coerce x 'short-float) - (coerce y 'short-float)))) + (let ((point (make-ns-point x y))) (send (send mirror 'window) :set-frame-top-left-point point) (#_free point))))) @@ -606,11 +603,9 @@ (%beagle-port-move-mirror-window port mirror mirror-transformation) (slet ((mirror-bounds (send mirror 'bounds)) (frame-origin (send mirror 'frame))) ;position + size _in parent_ - (let* ((x (coerce (floor (nth-value 0 (transform-position mirror-transformation 0 0))) - 'short-float)) - (y (coerce (floor (nth-value 1 (transform-position mirror-transformation 0 0))) - 'short-float)) - (point (ccl::make-ns-point x y))) + (let* ((x (floor (nth-value 0 (transform-position mirror-transformation 0 0)))) + (y (floor (nth-value 1 (transform-position mirror-transformation 0 0)))) + (point (make-ns-point x y))) ;; Skip this (for now...) #+nil (when (and (equal (pref frame-origin :ect.origin.x) x) --- /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2007/12/18 10:54:22 1.7 +++ /project/mcclim/cvsroot/mcclim/Backends/beagle/windowing/port.lisp 2008/05/16 14:05:28 1.8 @@ -164,16 +164,16 @@ ;;; From CLX/port.lisp -(defun %beagle-pixel (port color &key (alpha 1.0)) +(defun %beagle-pixel (port color &key (alpha #.(cg-floatify 1.0))) (let* ((table (slot-value port 'color-table)) (nscol (gethash color table))) (when (null nscol) (setf (gethash color table) (multiple-value-bind (r g b) (color-rgb color) - (let ((nsc (send (@class ns-color) :color-with-calibrated-red (coerce r 'short-float) - :green (coerce g 'short-float) - :blue (coerce b 'short-float) - :alpha (coerce alpha 'short-float)))) + (let ((nsc (send (@class ns-color) :color-with-calibrated-red (cg-floatify r) + :green (cg-floatify g) + :blue (cg-floatify b) + :alpha (cg-floatify alpha)))) (send nsc 'retain))))) (gethash color table))) From thenriksen at common-lisp.net Sat May 17 21:25:37 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 17 May 2008 17:25:37 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080517212537.09CE81123@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv7171/ESA Modified Files: esa.lisp Log Message: Improved the ESA minibuffer - can now resize itself if necessary and doesn't flicker. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/01 06:48:22 1.23 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/17 21:25:35 1.24 @@ -106,30 +106,45 @@ current message was set.")) (:default-initargs :scroll-bars nil - :display-function 'display-minibuffer - :display-time :no-clear - :incremental-redisplay t)) + :display-function 'display-minibuffer + :display-time :command-loop + :incremental-redisplay t)) + +(defmethod handle-repaint ((pane minibuffer-pane) region) + (when (and (message pane) + (> (get-universal-time) + (+ *minimum-message-time* (message-time pane)))) + (window-clear pane) + (setf (message pane) nil)) + (call-next-method)) + +(defmethod (setf message) :after (new-value (pane minibuffer-pane)) + (change-space-requirements pane)) + +(defmethod pane-needs-redisplay ((pane minibuffer-pane)) + ;; Always call the display function, never clear the window. This + ;; allows us to time-out the message in the minibuffer. + (values t nil)) -(defmethod stream-accept :before ((pane minibuffer-pane) type &rest args) - (declare (ignore type args)) - (window-clear pane) - (when (message pane) - (setf (message pane) nil) - ;; FIXME: If we do not redisplay here, the area occupied by the - ;; message will be blanked with a white rectangle at the first - ;; keystroke. - (redisplay-frame-pane (pane-frame pane) pane))) +(defun display-minibuffer (frame pane) + (declare (ignore frame)) + (handle-repaint pane +everywhere+)) (defmethod stream-accept :around ((pane minibuffer-pane) type &rest args) (declare (ignore args)) + (when (message pane) + (setf (message pane) nil)) + (window-clear pane) ;; FIXME: this isn't the friendliest way of indicating a parse ;; error: there's no feedback, unlike emacs' quite nice "[no ;; match]". - (loop - (handler-case - (with-input-focus (pane) - (return (call-next-method))) - (parse-error () nil)))) + (unwind-protect + (loop + (handler-case + (with-input-focus (pane) + (return (call-next-method))) + (parse-error () nil))) + (window-clear pane))) (defmethod stream-accept ((pane minibuffer-pane) type &rest args &key (view (stream-default-view pane)) @@ -139,6 +154,21 @@ ;; but we need to turn some of ACCEPT-1 off. (apply #'accept-1-for-minibuffer pane type args)) +(defmethod compose-space ((pane minibuffer-pane) &key width height) + (declare (ignore width height)) + (with-sheet-medium (medium pane) + (let* ((sr (call-next-method)) + (height (max (text-style-height (medium-merged-text-style medium) + medium) + (if (message pane) + (bounding-rectangle-height (message pane)) + 0)))) + (make-space-requirement + :height height :min-height height :max-height height + :width (space-requirement-width sr) + :min-width (space-requirement-min-width sr) + :max-width (space-requirement-max-width sr))))) + ;;; simpler version of McCLIM's internal operators of the same names: ;;; HANDLE-EMPTY-INPUT to make default processing work, EMPTY-INPUT-P ;;; and INVOKE-HANDLE-EMPTY-INPUT to support it. We don't support @@ -288,24 +318,15 @@ stream object object-type view :rescan nil)) (values object object-type))))) -(defun display-minibuffer (frame pane) - (declare (ignore frame)) - (if (message pane) - (if (> (get-universal-time) - (+ *minimum-message-time* (message-time pane))) - (setf (message pane) nil) - (replay-output-record (message pane) pane)) - ;; Even if there isn't a message, someone else might still have - ;; scribbled in the pane. We shouldn't disappoint them. - (replay (stream-output-history pane) pane))) - (defgeneric invoke-with-minibuffer-stream (minibuffer continuation)) (defmethod invoke-with-minibuffer-stream ((minibuffer minibuffer-pane) continuation) + (window-clear minibuffer) (setf (message minibuffer) - (with-output-to-output-record (minibuffer) + (with-new-output-record (minibuffer) (setf (message-time minibuffer) (get-universal-time)) - (funcall continuation minibuffer)))) + (filling-output (minibuffer :fill-width (bounding-rectangle-width minibuffer)) + (funcall continuation minibuffer))))) (defmethod invoke-with-minibuffer-stream ((minibuffer pointer-documentation-pane) continuation) (clim-extensions:with-output-to-pointer-documentation (stream (pane-frame minibuffer)) @@ -900,7 +921,7 @@ ;; for presentation-to-command-translators, ;; which are searched for in ;; (frame-command-table *application-frame*) - (redisplay-frame-pane ,frame (frame-standard-input ,frame) :force-p t) + (redisplay-frame-pane ,frame (frame-standard-input ,frame)) (setf (frame-command-table ,frame) command-table) (process-gestures-or-command ,frame)) (unbound-gesture-sequence (c) From thenriksen at common-lisp.net Sun May 18 09:09:23 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 18 May 2008 05:09:23 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080518090923.E8221581DB@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv18592/ESA Modified Files: esa-io.lisp Log Message: Handle file-errors when writing files in ESA. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/01/29 22:59:30 1.9 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:09:22 1.10 @@ -248,25 +248,28 @@ t))) (defmethod frame-save-buffer (application-frame buffer) - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (check-buffer-writability application-frame filepath buffer) - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from frame-save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil))) + (handler-case + (let ((filepath (or (filepath buffer) + (accept 'pathname :prompt "Save Buffer to File")))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from frame-save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) + (let ((backup-name (pathname-name filepath)) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil)) + (file-error (c) + (display-message "~A" c)))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. From thenriksen at common-lisp.net Sun May 18 09:20:22 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 18 May 2008 05:20:22 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080518092022.5F1CB3001A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv21883/ESA Modified Files: esa-io.lisp Log Message: Move error ESA-IO handling into commands. --- /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:09:22 1.10 +++ /project/mcclim/cvsroot/mcclim/ESA/esa-io.lisp 2008/05/18 09:20:21 1.11 @@ -136,7 +136,9 @@ If a buffer is already visiting that file, switch to that buffer. Does not create a file if the filename given does not name an existing file." - (find-file filepath)) + (handler-case (find-file filepath) + (file-error (e) + (display-message "~A" e)))) (set-key `(com-find-file ,*unsupplied-argument-marker*) 'esa-io-table '((#\x :control) (#\f :control))) @@ -248,28 +250,25 @@ t))) (defmethod frame-save-buffer (application-frame buffer) - (handler-case - (let ((filepath (or (filepath buffer) - (accept 'pathname :prompt "Save Buffer to File")))) - (check-buffer-writability application-frame filepath buffer) - (unless (check-file-times buffer filepath "Overwrite" "written") - (return-from frame-save-buffer)) - (when (and (probe-file filepath) (not (file-saved-p buffer))) - (let ((backup-name (pathname-name filepath)) - (backup-type (format nil "~A~~~D~~" - (pathname-type filepath) - (1+ (version-number filepath))))) - (rename-file filepath (make-pathname :name backup-name - :type backup-type)))) - (with-open-file (stream filepath :direction :output :if-exists :supersede) - (save-buffer-to-stream buffer stream)) - (setf (filepath buffer) filepath - (file-write-time buffer) (file-write-date filepath) - (name buffer) (filepath-filename filepath)) - (display-message "Wrote: ~a" (filepath buffer)) - (setf (needs-saving buffer) nil)) - (file-error (c) - (display-message "~A" c)))) + (let ((filepath (or (filepath buffer) + (accept 'pathname :prompt "Save Buffer to File")))) + (check-buffer-writability application-frame filepath buffer) + (unless (check-file-times buffer filepath "Overwrite" "written") + (return-from frame-save-buffer)) + (when (and (probe-file filepath) (not (file-saved-p buffer))) + (let ((backup-name (pathname-name filepath)) + (backup-type (format nil "~A~~~D~~" + (pathname-type filepath) + (1+ (version-number filepath))))) + (rename-file filepath (make-pathname :name backup-name + :type backup-type)))) + (with-open-file (stream filepath :direction :output :if-exists :supersede) + (save-buffer-to-stream buffer stream)) + (setf (filepath buffer) filepath + (file-write-time buffer) (file-write-date filepath) + (name buffer) (filepath-filename filepath)) + (display-message "Wrote: ~a" (filepath buffer)) + (setf (needs-saving buffer) nil))) (define-command (com-save-buffer :name t :command-table esa-io-table) () "Write the contents of the buffer to a file. @@ -283,10 +282,8 @@ :default-type 'pathname)) (if (needs-saving buffer) (handler-case (save-buffer buffer) - (buffer-writing-error (e) - (with-minibuffer-stream (minibuffer) - (let ((*print-escape* nil)) - (print-object e minibuffer))))) + ((or buffer-writing-error file-error) (e) + (display-message "~A" e))) (display-message "No changes need to be saved from ~a" (name buffer)))))) (set-key 'com-save-buffer 'esa-io-table '((#\x :control) (#\s :control))) From thenriksen at common-lisp.net Sun May 18 09:24:08 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sun, 18 May 2008 05:24:08 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/ESA Message-ID: <20080518092408.A27D17C073@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/ESA In directory clnet:/tmp/cvs-serv23401/ESA Modified Files: esa.lisp Log Message: Improve the ESA minibuffers handling of arbitrary output. --- /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/17 21:25:35 1.24 +++ /project/mcclim/cvsroot/mcclim/ESA/esa.lisp 2008/05/18 09:24:06 1.25 @@ -160,9 +160,7 @@ (let* ((sr (call-next-method)) (height (max (text-style-height (medium-merged-text-style medium) medium) - (if (message pane) - (bounding-rectangle-height (message pane)) - 0)))) + (bounding-rectangle-height (stream-output-history pane))))) (make-space-requirement :height height :min-height height :max-height height :width (space-requirement-width sr) From thenriksen at common-lisp.net Tue May 20 15:33:15 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 20 May 2008 11:33:15 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080520153315.7F49D281E8@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv13866/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added the ability to cancel a computation in the CLIM Listener by pressing the abort gesture. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/04/14 16:55:05 1.54 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 15:33:14 1.55 @@ -1519,14 +1519,36 @@ (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) - (let* ((- form) - (values (multiple-value-list (eval form)))) - (fresh-line) - (shuffle-specials form values) - (display-evalues values) - (fresh-line))) - - + (flet ((evaluate () + (let ((- form)) + (multiple-value-list (eval form))))) + ;; If possible, use a thread for evaluation, permitting us to + ;; interrupt it. + (let* ((start-time (get-internal-real-time)) + (values + (if clim-sys:*multiprocessing-p* + (catch 'done + (let* ((orig-process (clim-sys:current-process)) + (eval-process + (clim-sys:make-process + #'(lambda () + (let ((values (evaluate))) + (clim-sys:process-interrupt orig-process + #'(lambda () + (throw 'done values)))))))) + (handler-case (loop (read-gesture)) + (abort-gesture () + (clim-sys:destroy-process eval-process) + (with-text-style (t (make-text-style nil :italic nil)) + (format t "Aborted by user after ~F seconds." + (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second))) + (return-from com-eval))))) + (evaluate)))) + (fresh-line) + (shuffle-specials form values) + (display-evalues values) + (fresh-line)))) ;;; Some CLIM developer commands From thenriksen at common-lisp.net Tue May 20 16:12:09 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 20 May 2008 12:12:09 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080520161209.78DC53C005@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv28449/Apps/Listener Modified Files: dev-commands.lisp Log Message: Added better handling of abnormal exit when evaluating forms in the Listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 15:33:14 1.55 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:12:09 1.56 @@ -1519,36 +1519,53 @@ (define-command (com-eval :menu t :command-table lisp-commands) ((form 'clim:form :prompt "form")) - (flet ((evaluate () - (let ((- form)) - (multiple-value-list (eval form))))) - ;; If possible, use a thread for evaluation, permitting us to - ;; interrupt it. - (let* ((start-time (get-internal-real-time)) - (values + (let ((standard-output *standard-output*) + (standard-input *standard-input*)) + (flet ((evaluate () + (let ((- form) + (*standard-output* standard-output) + (*standard-input* standard-input) + error success) + (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) + (setf success t)) + (condition (e) + (setf error e) + (error e))) + (when (and error (not success)) + (return-from evaluate (cons :error error))))))) + ;; If possible, use a thread for evaluation, permitting us to + ;; interrupt it. + (let ((start-time (get-internal-real-time))) + (destructuring-bind (result . value) (if clim-sys:*multiprocessing-p* (catch 'done (let* ((orig-process (clim-sys:current-process)) (eval-process (clim-sys:make-process #'(lambda () - (let ((values (evaluate))) + (let ((result (evaluate))) (clim-sys:process-interrupt orig-process #'(lambda () - (throw 'done values)))))))) - (handler-case (loop (read-gesture)) + (throw 'done result)))))))) + (handler-case (loop for gesture = (read-gesture) + when (event-matches-gesture-name-p gesture :pause) + do (clim-sys:process-interrupt eval-process #'break)) (abort-gesture () (clim-sys:destroy-process eval-process) - (with-text-style (t (make-text-style nil :italic nil)) - (format t "Aborted by user after ~F seconds." - (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second))) - (return-from com-eval))))) - (evaluate)))) - (fresh-line) - (shuffle-specials form values) - (display-evalues values) - (fresh-line)))) + (cons :abort (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second)))))) + (evaluate)) + (ecase result + (:values + (fresh-line) + (shuffle-specials form value) + (display-evalues value) + (fresh-line)) + (:error (with-text-style (t (make-text-style nil :italic nil)) + (with-output-as-presentation (t value 'expression) + (format t "Aborted due to ~A: ~A" (type-of value) value)))) + (:abort (with-text-style (t (make-text-style nil :italic nil)) + (format t "Aborted by user after ~F seconds." value))))))))) ;;; Some CLIM developer commands From thenriksen at common-lisp.net Tue May 20 16:16:02 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 20 May 2008 12:16:02 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080520161602.E9F194C002@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv29122/Apps/Listener Modified Files: dev-commands.lisp Log Message: Listener now supports BREAKing of running evaluation by pressing the conveniently named Pause/Break key on the keyboard. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:12:09 1.56 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:16:02 1.57 @@ -1548,7 +1548,8 @@ #'(lambda () (throw 'done result)))))))) (handler-case (loop for gesture = (read-gesture) - when (event-matches-gesture-name-p gesture :pause) + when (and (typep gesture 'keyboard-event) + (eq (keyboard-event-key-name gesture) :pause)) do (clim-sys:process-interrupt eval-process #'break)) (abort-gesture () (clim-sys:destroy-process eval-process) From thenriksen at common-lisp.net Sat May 24 11:55:52 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 24 May 2008 07:55:52 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080524115552.178055205B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9861/Drei Modified Files: lisp-syntax.lisp Log Message: Random fixes for Lisp syntax highlighting. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/03 09:12:25 1.77 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2008/05/24 11:55:41 1.78 @@ -1809,10 +1809,13 @@ ;; We don't use `form-to-object' as we want to retrieve information ;; even about symbol that are not interned. (multiple-value-bind (symbol package) - (parse-symbol (form-string syntax symbol-form) :package *package*) + (parse-symbol (form-string syntax symbol-form) + :package (package-at-mark syntax (start-offset symbol-form))) (setf (keyword-symbol-p symbol-form) (eq package +keyword-package+) - (macroboundp symbol-form) (or (special-operator-p symbol) - (macro-function symbol)) + (macroboundp symbol-form) (when (eq (first-form (children (parent symbol-form))) + symbol-form) + (or (special-operator-p symbol) + (macro-function symbol))) (global-boundp symbol-form) (and (boundp symbol) (not (constantp symbol)))))) @@ -1909,8 +1912,8 @@ (string-form (:options :face +italic-face+)) (comment (*retro-comment-drawing-options*)) (literal-object-form (:options :function (object-drawer))) - (complete-token-form (:function #'(lambda (syntax form) - (cond ((symbol-form-is-macrobound-p syntax form) + (complete-token-form (:function #'(lambda (view form) + (cond ((symbol-form-is-macrobound-p (syntax view) form) +bold-face-drawing-options+) (t +default-drawing-options+))))) (reader-conditional-positive-form From thenriksen at common-lisp.net Sat May 24 11:57:16 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 24 May 2008 07:57:16 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080524115716.5F8211C0B9@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10040/Drei Modified Files: search-commands.lisp Log Message: Fix some old code that assumed Drei instances themselves contain points. --- /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/04/28 20:48:55 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/search-commands.lisp 2008/05/24 11:57:12 1.11 @@ -32,16 +32,16 @@ (defun simple-search (drei-instance search-function targets more-targets-predicate more-targets-fn) - (let ((old-buffer (buffer drei-instance)) - (old-offset (offset (point drei-instance)))) + (let ((old-buffer (buffer (view drei-instance))) + (old-offset (offset (point (view drei-instance))))) (activate-target-specification targets) - (or (loop until (funcall search-function (point drei-instance)) + (or (loop until (funcall search-function (point (view drei-instance))) if (funcall more-targets-predicate targets) do (funcall more-targets-fn targets) else return nil finally (return t)) - (setf (buffer drei-instance) old-buffer - (offset (point drei-instance)) old-offset)))) + (setf (buffer (view drei-instance)) old-buffer + (offset (point (view drei-instance))) old-offset)))) (defun simple-search-forward (drei-instance search-function &optional (targets (funcall *default-target-creator* drei-instance))) @@ -244,7 +244,7 @@ until (search-success-p (first (isearch-states (drei-instance)))) do (pop (isearch-states (drei-instance)))) (let ((state (first (isearch-states (drei-instance))))) - (setf (offset (point (drei-instance))) + (setf (offset (point (view (drei-instance)))) (if (search-forward-p state) (+ (offset (search-mark state)) (length (search-string state))) From thenriksen at common-lisp.net Sat May 24 12:00:44 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Sat, 24 May 2008 08:00:44 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Drei Message-ID: <20080524120044.D98FB4C043@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv10700/Drei Modified Files: input-editor.lisp Log Message: Rebind *original-stream* when unreading gesture to prevent annoying bugs. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/04/30 21:27:46 1.47 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2008/05/24 12:00:29 1.48 @@ -634,7 +634,8 @@ (rescan-if-necessary stream) (return-from stream-process-gesture gesture)) (when (proper-gesture-p gesture) - (unread-gesture gesture :stream (encapsulating-stream-stream stream))) + (let ((*original-stream* (encapsulating-stream-stream stream))) + (unread-gesture gesture :stream (encapsulating-stream-stream stream)))) (read-gestures-and-act stream gesture type)) (defmethod reset-scan-pointer ((stream drei-input-editing-mixin) From thenriksen at common-lisp.net Tue May 27 13:15:36 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 27 May 2008 09:15:36 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim Message-ID: <20080527131536.CC18D28277@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv3639 Modified Files: presentation-defs.lisp Log Message: Change over-eager call to DIRECTORY for pathname completion... should now use the entered input to create the wild pathname. Assumes Unix-style wild pathnames, but the whole pathname completion thing is Unix-specific anyway, so... --- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 09:26:49 1.77 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/05/27 13:15:36 1.78 @@ -1614,72 +1614,76 @@ 'pathname) (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)))))))) + (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 = (format nil "~A*.*" + (loop for start = 0 ; Replace * -> \* + for occurence = (position #\* so-far :start start) + until (= start (length so-far)) + until (null occurence) + do (replace so-far "\\*" :start1 occurence) + (setf start (+ occurence 2)) + finally (return 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) From thenriksen at common-lisp.net Tue May 27 15:30:33 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 27 May 2008 11:30:33 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080527153033.6EF5A7C088@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv21697/Apps/Listener Modified Files: dev-commands.lisp Log Message: In the Listener, handle abort gesture properly even if the eval-thread is in the debugger. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/20 16:16:02 1.57 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:30:32 1.58 @@ -1540,21 +1540,25 @@ (if clim-sys:*multiprocessing-p* (catch 'done (let* ((orig-process (clim-sys:current-process)) + (evaluating t) (eval-process (clim-sys:make-process #'(lambda () (let ((result (evaluate))) - (clim-sys:process-interrupt orig-process - #'(lambda () - (throw 'done result)))))))) - (handler-case (loop for gesture = (read-gesture) - when (and (typep gesture 'keyboard-event) - (eq (keyboard-event-key-name gesture) :pause)) - do (clim-sys:process-interrupt eval-process #'break)) - (abort-gesture () - (clim-sys:destroy-process eval-process) - (cons :abort (/ (- (get-internal-real-time) start-time) - internal-time-units-per-second)))))) + (when evaluating + (clim-sys:process-interrupt orig-process + #'(lambda () + (throw 'done result))))))))) + (unwind-protect + (handler-case (loop for gesture = (read-gesture) + when (and (typep gesture 'keyboard-event) + (eq (keyboard-event-key-name gesture) :pause)) + do (clim-sys:process-interrupt eval-process #'break)) + (abort-gesture () + (clim-sys:destroy-process eval-process) + (cons :abort (/ (- (get-internal-real-time) start-time) + internal-time-units-per-second)))) + (setf evaluating nil)))) (evaluate)) (ecase result (:values From thenriksen at common-lisp.net Tue May 27 15:53:55 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 27 May 2008 11:53:55 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080527155355.BD2C01705A@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv25296/Apps/Listener Modified Files: dev-commands.lisp Log Message: As per the advice of Nikodemus, only handle serious-condition in the Listener. Also rebind *error-output*. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:30:32 1.58 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:53:55 1.59 @@ -1525,10 +1525,11 @@ (let ((- form) (*standard-output* standard-output) (*standard-input* standard-input) + (*error-output* standard-output) error success) (unwind-protect (handler-case (prog1 (cons :values (multiple-value-list (eval form))) (setf success t)) - (condition (e) + (serious-condition (e) (setf error e) (error e))) (when (and error (not success)) From thenriksen at common-lisp.net Tue May 27 16:00:59 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Tue, 27 May 2008 12:00:59 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Apps/Listener Message-ID: <20080527160059.CF37B2828C@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Apps/Listener In directory clnet:/tmp/cvs-serv26543/Apps/Listener Modified Files: dev-commands.lisp Log Message: Handle BREAK in the Listener. --- /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 15:53:55 1.59 +++ /project/mcclim/cvsroot/mcclim/Apps/Listener/dev-commands.lisp 2008/05/27 16:00:58 1.60 @@ -1532,7 +1532,7 @@ (serious-condition (e) (setf error e) (error e))) - (when (and error (not success)) + (when (not success) (return-from evaluate (cons :error error))))))) ;; If possible, use a thread for evaluation, permitting us to ;; interrupt it. @@ -1568,8 +1568,10 @@ (display-evalues value) (fresh-line)) (:error (with-text-style (t (make-text-style nil :italic nil)) - (with-output-as-presentation (t value 'expression) - (format t "Aborted due to ~A: ~A" (type-of value) value)))) + (if value + (with-output-as-presentation (t value 'expression) + (format t "Aborted due to ~A: ~A" (type-of value) value)) + (format t "Aborted for unknown reasons (possibly use of ~A)." 'break)))) (:abort (with-text-style (t (make-text-style nil :italic nil)) (format t "Aborted by user after ~F seconds." value))))))))) From thenriksen at common-lisp.net Thu May 29 19:11:28 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 29 May 2008 15:11:28 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20080529191128.AE80E7A019@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11208/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: Improved CLIM-SYS:CURRENT-PROCESS on SBCL. Should now always return the correct process, even within processes not started by McCLIM. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2007/12/16 23:20:11 1.11 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:28 1.12 @@ -44,12 +44,9 @@ (defvar *current-process* (%make-process - :name "initial process" :function nil - :thread - #+#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - sb-thread:*current-thread* - #-#.(cl:if (cl:find-symbol "THREAD-NAME" "SB-THREAD") '(and) '(or)) - (sb-thread:current-thread-id))) + :name (sb-thread:thread-name sb-thread:*current-thread*) + :function nil + :thread sb-thread:*current-thread*)) (defvar *all-processes* (list *current-process*)) @@ -85,7 +82,15 @@ (sb-thread:terminate-thread (process-thread process))) (defun current-process () - *current-process*) + (if (eq (process-thread *current-process*) sb-thread:*current-thread*) + *current-process* + (setf *current-process* + (or (find sb-thread:*current-thread* *all-processes* + :key #'process-thread) + (%make-process + :name (sb-thread:thread-name sb-thread:*current-thread*) + :function nil + :thread sb-thread:*current-thread*))))) (defun all-processes () ;; we're calling DELETE on *ALL-PROCESSES*. If we look up the value From thenriksen at common-lisp.net Thu May 29 19:11:47 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 29 May 2008 15:11:47 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20080529191147.53B4A7A01B@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11272/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: Move *all-processes* handling into the function passed to SB-THREAD:MAKE-THREAD. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:28 1.12 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:45 1.13 @@ -48,7 +48,9 @@ :function nil :thread sb-thread:*current-thread*)) -(defvar *all-processes* (list *current-process*)) +(defvar *all-processes* (list *current-process*) + "A list of processes created by McCLIM, plus the one that was +running when this file was loaded.") (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*")) @@ -64,21 +66,21 @@ (defun make-process (function &key name) (let ((p (%make-process :name name :function function))) - (sb-thread:with-mutex (*all-processes-lock*) - (pushnew p *all-processes*)) (restart-process p))) (defun restart-process (p) (labels ((boing () (let ((*current-process* p)) - (funcall (process-function p) )))) + (sb-thread:with-mutex (*all-processes-lock*) + (pushnew p *all-processes*)) + (unwind-protect (funcall (process-function p)) + (sb-thread:with-mutex (*all-processes-lock*) + (setf *all-processes* (delete p *all-processes*))))))) (when (process-thread p) (sb-thread:terminate-thread p)) (when (setf (process-thread p) (sb-thread:make-thread #'boing :name (process-name p))) p))) (defun destroy-process (process) - (sb-thread:with-mutex (*all-processes-lock*) - (setf *all-processes* (delete process *all-processes*))) (sb-thread:terminate-thread (process-thread process))) (defun current-process () @@ -87,6 +89,8 @@ (setf *current-process* (or (find sb-thread:*current-thread* *all-processes* :key #'process-thread) + ;; Don't add this to *all-processes*, because we don't + ;; control it. (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil From thenriksen at common-lisp.net Thu May 29 19:12:03 2008 From: thenriksen at common-lisp.net (thenriksen) Date: Thu, 29 May 2008 15:12:03 -0400 (EDT) Subject: [mcclim-cvs] CVS mcclim/Lisp-Dep Message-ID: <20080529191203.AFD0DA182@common-lisp.net> Update of /project/mcclim/cvsroot/mcclim/Lisp-Dep In directory clnet:/tmp/cvs-serv11374/Lisp-Dep Modified Files: mp-sbcl.lisp Log Message: SBCL multiprocessing patch from Christophe that allows saved cores to work. --- /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:11:45 1.13 +++ /project/mcclim/cvsroot/mcclim/Lisp-Dep/mp-sbcl.lisp 2008/05/29 19:12:03 1.14 @@ -42,16 +42,24 @@ function thread) -(defvar *current-process* +(defun make-current-process () (%make-process :name (sb-thread:thread-name sb-thread:*current-thread*) :function nil :thread sb-thread:*current-thread*)) +(defvar *current-process* (make-current-process)) + (defvar *all-processes* (list *current-process*) "A list of processes created by McCLIM, plus the one that was running when this file was loaded.") +(defun reinit-processes () + (setf *current-process* (make-current-process)) + (setf *all-processes* (list *current-process*))) + +(push 'reinit-processes sb-ext:*init-hooks*) + (defvar *all-processes-lock* (sb-thread:make-mutex :name "Lock around *ALL-PROCESSES*"))