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

[mcclim-cvs] CVS update: mcclim/Apps/Inspector/inspector.lisp
by pscott＠common-lisp.net 04 Mar '05

04 Mar '05

Update of /project/mcclim/cvsroot/mcclim/Apps/Inspector In directory common-lisp.net:/tmp/cvs-serv3338 Modified Files: inspector.lisp Log Message: Fixed a bunch of little bugs. Added some comments. Package display was ugly in one place I forgot to change earlier, so I changed it. Numbers and strings had some weird display problems, which I've mostly fixed (and I can only hope that I didn't introduce minor bugs in some other part of the program). I think this is ready for the Mothering Sunday release! Date: Fri Mar 4 22:32:09 2005 Author: pscott Index: mcclim/Apps/Inspector/inspector.lisp diff -u mcclim/Apps/Inspector/inspector.lisp:1.22 mcclim/Apps/Inspector/inspector.lisp:1.23 --- mcclim/Apps/Inspector/inspector.lisp:1.22 Wed Feb 16 00:12:07 2005 +++ mcclim/Apps/Inspector/inspector.lisp Fri Mar 4 22:32:08 2005 @@ -304,9 +304,10 @@ (formatting-cell (pane) (inspect-object car pane))))))) (defmethod inspect-object ((object cons) pane) + ;; Decide how to display the cons by looking in cons-cell-dico (if (gethash object (cons-cell-dico *application-frame*)) - (inspect-cons-as-cells object pane) - (inspect-cons-as-list object pane))) + (inspect-cons-as-cells object pane) + (inspect-cons-as-list object pane))) (defmethod inspect-object-briefly ((object hash-table) pane) @@ -383,9 +384,13 @@ (print-documentation object pane))) (defmethod inspect-object-briefly ((object package) pane) + ;; Display as 'Package: "PACKAGE-NAME"'. We're doing something a + ;; little unusual here by not bolding the "Package:" part. This may + ;; be a tad inconsistent, but the other way looks very odd. (with-output-as-presentation (pane object (presentation-type-of object)) (format pane "Package: ~S" (package-name object)))) + (defmethod inspect-object ((object package) pane) (inspector-table (format pane "Package: ~S" (package-name object)) @@ -408,7 +413,8 @@ (inspector-table-row (princ "Uses:") (dolist (uses (package-use-list object)) - (inspect-object uses pane))))) + (fresh-line pane) + (inspect-object uses pane))))) (defmethod inspect-object ((object vector) pane) (with-output-as-presentation @@ -423,15 +429,27 @@ (formatting-cell (pane) (princ ")" pane)))))) +;; For some strange reason, objects that are displayed with PRINT are +;; slightly wider than those displayed with PRIN1. Generally, PRIN1 is +;; what you want, and to prevent strings and numbers from getting +;; slightly wider when they're toggled to full inspection, the +;; INSPECT-OBJECT methods for them call the INSPECT-OBJECT-BRIEFLY +;; methods which do the right thing. (defmethod inspect-object-briefly ((object string) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object))) + (prin1 object))) + +(defmethod inspect-object ((object string) pane) + (inspect-object-briefly object pane)) (defmethod inspect-object-briefly ((object number) pane) (with-output-as-presentation (pane object (presentation-type-of object)) - (print object))) + (prin1 object))) + +(defmethod inspect-object ((object number) pane) + (inspect-object-briefly object pane)) (defun inspect-complex (object pane) "Inspect a complex number. Since complex numbers should be inspected

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/package.lisp
by afuchs＠common-lisp.net 04 Mar '05

04 Mar '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv20688 Modified Files: package.lisp Log Message: Tom Winchester's patch to package.lisp to adapt the beagle to the new backend protocol Date: Fri Mar 4 08:54:43 2005 Author: afuchs Index: mcclim/Backends/beagle/package.lisp diff -u mcclim/Backends/beagle/package.lisp:1.1 mcclim/Backends/beagle/package.lisp:1.2 --- mcclim/Backends/beagle/package.lisp:1.1 Sun Jul 11 21:48:16 2004 +++ mcclim/Backends/beagle/package.lisp Fri Mar 4 08:54:42 2005 @@ -43,7 +43,7 @@ #:port-disable-sheet #:port-motion-hints #:port-force-output - #:set-port-keyboard-focus + #:%set-port-keyboard-focus #:set-sheet-pointer-cursor ;; #:port-set-mirror-region

1 0

[mcclim-cvs] CVS update: mcclim/Backends/beagle/events.lisp
by afuchs＠common-lisp.net 04 Mar '05

04 Mar '05

Update of /project/mcclim/cvsroot/mcclim/Backends/beagle In directory common-lisp.net:/tmp/cvs-serv19834 Modified Files: events.lisp Log Message: Commit Tom Winchester's patch to make events.lisp compile with the new backend protocol. Date: Fri Mar 4 08:35:40 2005 Author: afuchs Index: mcclim/Backends/beagle/events.lisp diff -u mcclim/Backends/beagle/events.lisp:1.4 mcclim/Backends/beagle/events.lisp:1.5 --- mcclim/Backends/beagle/events.lisp:1.4 Sat Aug 21 22:51:28 2004 +++ mcclim/Backends/beagle/events.lisp Fri Mar 4 08:35:39 2005 @@ -28,7 +28,7 @@ #|| -$Id: events.lisp,v 1.4 2004/08/21 20:51:28 duncan Exp $ +$Id: events.lisp,v 1.5 2005/03/04 07:35:39 afuchs Exp $ All these are copied pretty much from CLX/port.lisp @@ -334,7 +334,7 @@ (target-sheet (port-lookup-sheet-for-view *beagle-port* target-view))) (unless (null target-sheet) (format *debug-io* "Setting focus in *beagle-port* onto (hopefully correct) sheet: ~S~%" target-sheet) - (set-port-keyboard-focus target-sheet *beagle-port*)))))) + (%set-port-keyboard-focus target-sheet *beagle-port*)))))) ((send (send notification 'name) :is-equal-to-string #@"NSWindowDidExposeNotification") (setf return-event (make-instance 'window-repaint-event :timestamp (incf timestamp) @@ -720,7 +720,7 @@ ;;; Cocoa note: the Frame (NSWindow) must be made key for us to receive events; but they ;;; must then be sent to the Sheet that has focus. -(defmethod set-port-keyboard-focus (focus (port beagle-port)) +(defmethod %set-port-keyboard-focus (focus (port beagle-port) &key timestamp) (let ((mirror (sheet-mirror focus))) (debug-log 2 "events.lisp:set-port-keyboard-focus - got mirror ~S~%" mirror) (when mirror

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 01 Mar '05

01 Mar '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv28245 Modified Files: mcclim.asd Log Message: without-package-locks is in cmucl's EXTENSIONS package. Date: Tue Mar 1 16:46:14 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.3 mcclim/mcclim.asd:1.4 --- mcclim/mcclim.asd:1.3 Mon Feb 28 17:23:20 2005 +++ mcclim/mcclim.asd Tue Mar 1 16:46:13 2005 @@ -39,8 +39,8 @@ (unless (ignore-errors (ext:search-list "gray-streams:")) (setf (ext:search-list "gray-streams:") '("target:pcl/" "library:subsystems/"))) - (if (fboundp 'without-package-locks) - (without-package-locks + (if (fboundp 'extensions:without-package-locks) + (extensions:without-package-locks (load "gray-streams:gray-streams-library")) (load "gray-streams:gray-streams-library"))) #-clx

1 0

[mcclim-cvs] CVS update: mcclim/mcclim.asd
by afuchs＠common-lisp.net 28 Feb '05

28 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv15499 Modified Files: mcclim.asd Log Message: Add two dependencies spotted by Tim Daly Jr. Date: Mon Feb 28 17:23:21 2005 Author: afuchs Index: mcclim/mcclim.asd diff -u mcclim/mcclim.asd:1.2 mcclim/mcclim.asd:1.3 --- mcclim/mcclim.asd:1.2 Mon Feb 21 17:36:30 2005 +++ mcclim/mcclim.asd Mon Feb 28 17:23:20 2005 @@ -95,11 +95,11 @@ #| fall back |# "mp-nil")))) (:file "utils" :depends-on ("decls" "Lisp-Dep")) (:file "design" :depends-on ("decls" "Lisp-Dep" "utils")) - (:file "X11-colors" :depends-on ("decls" "Lisp-Dep")) + (:file "X11-colors" :depends-on ("decls" "Lisp-Dep" "design")) (:file "coordinates" :depends-on ("decls" "Lisp-Dep")) (:file "setf-star" :depends-on ("decls" "Lisp-Dep")) (:file "transforms" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils")) - (:file "regions" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star")) + (:file "regions" :depends-on ("decls" "Lisp-Dep" "coordinates" "utils" "transforms" "setf-star" "design")) (:file "sheets" :depends-on ("decls" "Lisp-Dep" "utils" "transforms" "regions")) (:file "pixmap" :depends-on ("decls" "Lisp-Dep" "sheets" "transforms" "regions")) (:file "events" :depends-on ("decls" "Lisp-Dep" "transforms" "sheets" "utils")) @@ -179,6 +179,7 @@ ((:file "text-formatting") (:file "input-editing") (:file "presentations") + (:file "defresource") (:file "presentation-defs" :depends-on ("input-editing" "presentations")) (:file "pointer-tracking" :depends-on ("input-editing")) (:file "commands" :depends-on ("input-editing" "presentations" "presentation-defs"))

1 0

[mcclim-cvs] CVS update: mcclim/Backends/CLX/port.lisp
by ahefner＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/mcclim/cvsroot/mcclim/Backends/CLX In directory common-lisp.net:/tmp/cvs-serv23633/Backends/CLX Modified Files: port.lisp Log Message: Attempt to fix some issues with text selection. Send Latin 1 in response to :STRING and :COMPOUND_TEXT requests, request selections as :STRING by default, fall back to cut buffer contents when a selection-notify event does not supply a property. Date: Mon Feb 28 00:07:43 2005 Author: ahefner Index: mcclim/Backends/CLX/port.lisp diff -u mcclim/Backends/CLX/port.lisp:1.107 mcclim/Backends/CLX/port.lisp:1.108 --- mcclim/Backends/CLX/port.lisp:1.107 Tue Feb 22 04:14:28 2005 +++ mcclim/Backends/CLX/port.lisp Mon Feb 28 00:07:41 2005 @@ -1377,67 +1377,72 @@ (defmethod release-selection ((port clx-port) &optional time) (xlib:set-selection-owner - (clim-clx::clx-port-display port) + (clx-port-display port) :primary nil time) (setf (selection-owner port) nil)) (defmethod request-selection ((port clx-port) requestor time) - (xlib:convert-selection :primary :UTF8_STRING requestor :bounce time)) + (xlib:convert-selection :primary :STRING requestor :bounce time)) -(defmethod get-selection-from-event ((event clx-selection-notify-event)) - (when (null (selection-event-property event)) - (format *trace-output* "~&;; Notify property is null! Why did this happen?~%")) - (map 'string #'code-char - (xlib:get-property (sheet-direct-mirror (event-sheet event)) - (selection-event-property event) - ;; :type :text - :delete-p t - :result-type 'vector))) +(defmethod get-selection-from-event ((port clx-port) (event clx-selection-notify-event)) + ; (describe event *trace-output*) + (if (null (selection-event-property event)) + (progn + (format *trace-output* "~&;; Oops, selection-notify property is null. Trying the cut buffer instead..~%") + (xlib:cut-buffer (clx-port-display port))) + (map 'string #'code-char + (xlib:get-property (sheet-direct-mirror (event-sheet event)) + (selection-event-property event) + ;; :type :text + :delete-p t + :result-type 'vector)))) -(defmethod send-selection ((event clx-selection-request-event) string) +;; Incredibly crappy broken unportable Latin 1 encoder which should be +;; replaced by various implementation-specific versions. +(defun latin1-encode (string) + (delete-if (lambda (x) (or (< x 0) + (> x 255))) + (map 'vector #'char-code string))) + +;; TODO: INCR property? +(defmethod send-selection ((port clx-port) (event clx-selection-request-event) string) (let ((requestor (selection-event-requestor event)) (property (selection-event-property event)) (target (selection-event-target event)) (time (event-timestamp event))) (when (null property) - (format *trace-output* "~&* Requestor property is null! *~%")) + (format *trace-output* "~&* Requestor property is null! *~%")) (describe event *trace-output*) (finish-output *trace-output*) - (cond ((member target '(:UTF8_STRING :STRING :TEXT)) - (xlib:change-property requestor property - (utf-8-encode - (concatenate 'vector (map 'vector #'char-code string))) - ;;:UTF8_STRING ;### - target - 8) - (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target target ;; :UTF8_STRING - :property property - :time time)) - ((member target '(:COMPOUND_TEXT)) - (xlib:change-property requestor property - (vector 65 65 67 - #x1B #x24 #x29 #x41 - #xA1 #xD4 - 67 65 67) - :COMPOUND_TEXT - 8) - (xlib:send-event requestor + (flet ((send-event (&key target (property property)) + (format *trace-output* + "~&;; clim-clx::send-selection - Requested target ~A, sent ~A to property ~A.~%" + (selection-event-target event) + target + property) + (xlib:send-event requestor :selection-notify nil :window requestor :selection :primary - :target :COMPOUND_TEXT + :target target :property property - :time time)) - (t - (xlib:send-event requestor - :selection-notify nil - :window requestor - :selection :primary - :target :UTF8_STRING ;;target - :property nil ;;property :time time))) + (cond ((member target '(:UTF8_STRING :TEXT)) + (xlib:change-property requestor property + (utf-8-encode + (concatenate 'vector (map 'vector #'char-code string))) + :UTF8_STRING + 8) + (send-event :target :UTF8_STRING)) + ((member target '(:STRING :COMPOUND_TEXT)) + (xlib:change-property requestor property + (latin1-encode string) + :COMPOUND_TEXT + 8) + (send-event :target :COMPOUND_TEXT)) + (t + (format *trace-output* + "~&;; Warning, unhandled type \"~A\". Trying to send as UTF8_STRING.~%" + target) + (send-event :target :UTF8_STRING :property nil)))) ;; ... (xlib:display-force-output (xlib:window-display requestor))))

1 0

[mcclim-cvs] CVS update: mcclim/text-selection.lisp
by ahefner＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv23633 Modified Files: text-selection.lisp Log Message: Attempt to fix some issues with text selection. Send Latin 1 in response to :STRING and :COMPOUND_TEXT requests, request selections as :STRING by default, fall back to cut buffer contents when a selection-notify event does not supply a property. Date: Mon Feb 28 00:07:39 2005 Author: ahefner Index: mcclim/text-selection.lisp diff -u mcclim/text-selection.lisp:1.4 mcclim/text-selection.lisp:1.5 --- mcclim/text-selection.lisp:1.4 Mon Feb 14 17:31:41 2005 +++ mcclim/text-selection.lisp Mon Feb 28 00:07:36 2005 @@ -72,10 +72,10 @@ (defgeneric bind-selection (port window &optional time) (:documentation "Take ownership of the selection.")) -(defgeneric send-selection (request-event string) +(defgeneric send-selection (port request-event string) (:documentation "Send 'string' to a client in response to a selection-request-event.")) -(defgeneric get-selection-from-event (event) +(defgeneric get-selection-from-event (port event) (:documentation "Given a selection-notify event, return a string containing the incoming selection.")) @@ -244,9 +244,7 @@ :sheet owner :selection :primary)))) (when (bind-selection (port pane) pane (event-timestamp event)) - (setf (selection-owner (port pane)) pane)) - ;; - ))) + (setf (selection-owner (port pane)) pane))))) (defun repaint-markings (pane old-markings new-markings) (let ((old-region (reduce #'region-union (mapcar #'(lambda (x) (marking-region pane x)) old-markings) @@ -377,18 +375,18 @@ ;;;; Selections Events (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) - (event selection-clear-event)) + (event selection-clear-event)) (pane-clear-markings pane (event-timestamp event))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) - (event selection-request-event)) - (send-selection event (fetch-selection pane))) + (event selection-request-event)) + (send-selection (port pane) event (fetch-selection pane))) (defmethod dispatch-event :around ((pane cut-and-paste-mixin #|extended-output-stream|#) (event selection-notify-event)) - (let ((matter (get-selection-from-event event))) + (let ((matter (get-selection-from-event (port pane) event))) #+NIL (format *trace-output* "Got ~S.~%" matter) (loop for c across matter do

1 0

[mcclim-cvs] CVS update: mcclim/input-editing.lisp
by tmoore＠common-lisp.net 27 Feb '05

27 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv13917 Modified Files: input-editing.lisp Log Message: Fixed input editing problem reported by Luke Gorrie. Some old code in stream-read-gesture was causing the scan pointer to be incremented twice in some cases. Date: Sun Feb 27 01:06:28 2005 Author: tmoore Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.45 mcclim/input-editing.lisp:1.46 --- mcclim/input-editing.lisp:1.45 Fri Feb 25 15:15:17 2005 +++ mcclim/input-editing.lisp Sun Feb 27 01:06:27 2005 @@ -141,13 +141,7 @@ (incf scan-pointer) (throw-object-ptype (goatee::object gesture) (goatee::result-type gesture))) - (t (incf scan-pointer))) - (if (characterp gesture) - (progn - (unless peek-p - (incf scan-pointer)) - (return-from stream-read-gesture gesture)) - (incf scan-pointer)))) + (t (incf scan-pointer))))) ;; The scan pointer should not be greater than the insertion pointer ;; because the code that set the insertion pointer should have queued ;; a rescan.

1 0

[mcclim-cvs] CVS update: mcclim/dialog.lisp mcclim/input-editing.lisp mcclim/presentation-defs.lisp
by tmoore＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv31004 Modified Files: dialog.lisp input-editing.lisp presentation-defs.lisp Log Message: Changed the handling of "empty input" for the purposes of returning a default value from ACCEPT. I eliminated the around method on STREAM-READ-CHAR that looked for activation/delimiter gestures and replaced it with an error handler on SIMPLE-PARSE-ERROR. The major effect of this is that (accept 'string) now return the empty string if the call to ACCEPT is not passed a default; other accept methods can return something useful for empty input too. This fixes some problems in the address book demo and with dialogs in general. Date: Fri Feb 25 15:15:17 2005 Author: tmoore Index: mcclim/dialog.lisp diff -u mcclim/dialog.lisp:1.18 mcclim/dialog.lisp:1.19 --- mcclim/dialog.lisp:1.18 Tue Feb 22 15:00:10 2005 +++ mcclim/dialog.lisp Fri Feb 25 15:15:17 2005 @@ -256,6 +256,13 @@ :key #'query-identifier :test #'equal)) (align (align-prompts stream))) (unless query + ;; If there's no default but empty input could return a sensible value, + ;; use that as a default. + (unless default-supplied-p + (setq default + (ignore-errors (accept-from-string type + "" + :view +textual-view+ )))) (setq query (make-instance 'query :query-identifier query-identifier :ptype type Index: mcclim/input-editing.lisp diff -u mcclim/input-editing.lisp:1.44 mcclim/input-editing.lisp:1.45 --- mcclim/input-editing.lisp:1.44 Tue Feb 22 15:00:11 2005 +++ mcclim/input-editing.lisp Fri Feb 25 15:15:17 2005 @@ -848,76 +848,76 @@ ;;; Infrasructure for detecting empty input, thus allowing accept-1 ;;; to supply a default. -;;; continuation = (stream scan-pointer <function of one arg (gesture)> -;;; activation-gestures delimiter gestures) -(defvar *empty-input-continuations* nil) - -(defun invoke-empty-input (stream gesture) - "Invoke the continuation of the empty `accept' before the first non-empty - accept `gesture' must be a member of that `accept''s activation or continuation - gestures." - (let* ((activationp (activation-gesture-p gesture)) - (scan-pointer (if activationp ;activation gestures don't appear in - ;the bufffer - (stream-scan-pointer stream) - (1- (stream-scan-pointer stream))))) - (loop - with active-continuation-function = nil - for continuation in *empty-input-continuations* - for (cont-stream cont-scan-pointer func activations delimeters) - = continuation - while (and (eq stream cont-stream) - (eql scan-pointer cont-scan-pointer)) - when (if activationp - (gesture-match gesture activations) - (gesture-match gesture delimeters)) - do (setq active-continuation-function func) - end - finally (when active-continuation-function - (unread-char gesture stream) - (funcall active-continuation-function))) - t)) - -(defmethod stream-read-gesture :around ((stream empty-input-mixin) - &key timeout peek-p - input-wait-test - input-wait-handler - pointer-button-press-handler) - (declare (ignore timeout input-wait-test input-wait-handler - pointer-button-press-handler)) - (if peek-p - (call-next-method) - (multiple-value-bind (gesture reason) - (call-next-method) - (when (and gesture - (or (activation-gesture-p gesture) - (delimiter-gesture-p gesture))) - (invoke-empty-input stream gesture)) - ;; invoke-empty-input won't return if it can invoke a continuation - (values gesture reason)))) - (defmacro handle-empty-input ((stream) input-form &body handler-forms) "Establishes a context on `stream' (a `standard-input-editing-stream') in - which empty input entered in `input-form' i.e., an activation gesture or - delimiter gesture typed with no other characters, may transfer control to - `handler-forms'. The gesture that caused the transfer remains to be read in - `stream'. Control is transferred to the outermost `handle-empty-input' form - that is empty. + which empty input entered in `input-form' may transfer control to + `handler-forms'. Empty input is assumed when a simple-parse-error is + signalled and there is a delimeter gesture or activation gesture in the + stream at the position where `input-form' began its input. The gesture that + caused the transfer remains to be read in `stream'. Control is transferred to + the outermost `handle-empty-input' form that is empty. Note: noise strings in the buffer, such as the prompts of recursive calls to `accept', cause input to not be empty. However, the prompt generated by `accept' is generally not part of its own empty input context." - (with-gensyms (return-block context-block) - `(block ,return-block - (block ,context-block - (let ((*empty-input-continuations* - (cons (list ,stream - (stream-scan-pointer ,stream) - #'(lambda () - (return-from ,context-block)) - *activation-gestures* - *delimiter-gestures*) - *empty-input-continuations*))) - (return-from ,return-block ,input-form))) - ,@handler-forms))) + (with-gensyms (input-cont handler-cont) + `(flet ((,input-cont () + ,input-form) + (,handler-cont () + ,@handler-forms)) + (declare (dynamic-extent #',input-cont #',handler-cont)) + (invoke-handle-empty-input ,stream #',input-cont #',handler-cont)))) + +(define-condition empty-input-condition (simple-condition) + ((stream :reader empty-input-condition-stream :initarg :stream))) + +;;; The code that signalled the error might have consumed the gesture, or +;;; not. +;;; XXX Actually, it would be a violation of the `accept' protocol to consume +;;; the gesture, but who knows what random accept methods are doing. +(defun empty-input-p (stream begin-scan-pointer completion-gestures) + (let ((scan-pointer (stream-scan-pointer stream)) + (fill-pointer (fill-pointer (stream-input-buffer stream)))) + ;; activated? + (cond ((and (eql begin-scan-pointer scan-pointer) + (eql scan-pointer fill-pointer)) + t) + ((or (eql begin-scan-pointer scan-pointer) + (eql begin-scan-pointer (1- scan-pointer))) + (let ((gesture (aref (stream-input-buffer stream) + begin-scan-pointer))) + (and (characterp gesture) + (gesture-match gesture completion-gestures)))) + (t nil)))) + +;;; The control flow in here might be a bit confusing. The handler catches +;;; parse errors from accept forms and checks if the input stream is empty. If +;;; so, it resignals an empty-input-condition to see if an outer call to +;;; accept is empty and wishes to handle this situation. We don't resignal the +;;; parse error itself because it might get handled by a handler on ERROR in an +;;; accept method or in user code, which would screw up the default mechanism. +;;; +;;; If the situation is not handled in the innermost empty input handler, +;;; either directly or as a result of resignalling, then it won't be handled +;;; by any of the outer handlers as the stack unwinds, because EMPTY-INPUT-P +;;; will return nil. +(defun invoke-handle-empty-input + (stream input-continuation handler-continuation) + (unless (input-editing-stream-p stream) + (return-from invoke-handle-empty-input (funcall input-continuation))) + (let ((begin-scan-pointer (stream-scan-pointer stream)) + (completion-gestures *completion-gestures*)) + (block empty-input + (handler-bind (((or simple-parse-error empty-input-condition) + #'(lambda (c) + (when (empty-input-p stream + begin-scan-pointer + completion-gestures) + (if (typep c 'empty-input-condition) + (signal c) + (signal 'empty-input-condition :stream stream)) + ;; No one else wants to handle it, so we will + (return-from empty-input nil))))) + (return-from invoke-handle-empty-input (funcall input-continuation)))) + (funcall handler-continuation))) Index: mcclim/presentation-defs.lisp diff -u mcclim/presentation-defs.lisp:1.42 mcclim/presentation-defs.lisp:1.43 --- mcclim/presentation-defs.lisp:1.42 Tue Feb 22 15:00:11 2005 +++ mcclim/presentation-defs.lisp Fri Feb 25 15:15:17 2005 @@ -1082,6 +1082,12 @@ (declare (ignore object acceptably for-context-type)) (write-string "None" stream)) +(define-presentation-method accept ((type null) stream (view textual-view) + &key) + (values (completing-from-suggestions (stream) + (suggest "None" nil) + (suggest "" nil)))) + (define-presentation-type boolean () :inherit-from t) @@ -1388,12 +1394,15 @@ (princ object stream)) (define-presentation-method accept ((type string) stream (view textual-view) - &key) + &key (default nil defaultp) + (default-type type)) (let ((result (read-token stream))) (cond ((numberp length) (if (eql length (length result)) (values result type) (input-not-of-required-type result type))) + ((and (zerop (length result)) defaultp) + (values default default-type)) (t (values result type))))) (define-presentation-type pathname ()

1 0

[mcclim-cvs] CVS update: mcclim/gadgets.lisp
by ahefner＠common-lisp.net 25 Feb '05

25 Feb '05

Update of /project/mcclim/cvsroot/mcclim In directory common-lisp.net:/tmp/cvs-serv4833 Modified Files: gadgets.lisp Log Message: Fix gadget output records after recent coordinate changes, with help from Anthony Juckel and Mikemac. Date: Fri Feb 25 07:03:03 2005 Author: ahefner Index: mcclim/gadgets.lisp diff -u mcclim/gadgets.lisp:1.87 mcclim/gadgets.lisp:1.88 --- mcclim/gadgets.lisp:1.87 Mon Jan 31 07:09:55 2005 +++ mcclim/gadgets.lisp Fri Feb 25 07:03:02 2005 @@ -2699,12 +2699,8 @@ (width (space-requirement-width sr)) (height (space-requirement-height sr))) (allocate-space child width height) - (setf (gadget record) child) - (with-slots (x1 x2 y1 y2) record - (setf x1 x - y1 y - x2 (+ x width) - y2 (+ y height))))) + (setf (gadget record) child + (rectangle-edges* record) (values x y (+ x width) (+ y height))))) (defmethod note-output-record-got-sheet ((record gadget-output-record) sheet) (multiple-value-bind (x y) (output-record-position record)

1 0