mcclim-cvs

mcclim-cvs@common-lisp.net

1697 discussions

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 07 Dec '06

07 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv29673 Modified Files: input-editor.lisp Log Message: Improved the support for the CLIM 2.2-specified input-editor interface, in particular, integration of the input-buffer with the Drei buffer. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/06 13:00:00 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/07 14:03:00 1.11 @@ -175,41 +175,116 @@ ;; want to permit the user to undo input for this context. (clear-undo-history (buffer (drei-instance stream)))) -(defun update-drei-buffer (stream) - "Update the Drei buffer of the Drei instance used by `stream' -if the `input-buffer-array' of `stream' is non-NIl. This will set -the contents of the array to the contents of the array up to the -fill pointer. When this function returns, the -`input-buffer-array' of `stream' will be NIL. Also, the syntax -will be up-to-date." +(defun buffer-array-mismatch (sequence1 sequence2 + &key (from-end nil) + (start1 0) + (start2 0)) + "Like `cl:mismatch', but supporting fewer keyword arguments, +and the two sequences can be Drei buffers instead." + (flet ((seq-elt (seq i) + (typecase seq + (drei-buffer (buffer-object seq i)) + (array (aref seq i)))) + (seq-length (seq) + (typecase seq + (drei-buffer (size seq)) + (array (length seq))))) + (if from-end + (loop + for index1 downfrom (1- (seq-length sequence1)) to 0 + for index2 downfrom (1- (seq-length sequence2)) to 0 + unless (= index1 index2 0) + if (or (= index1 0) + (= index2 0)) + return index1 + unless (eql (seq-elt sequence1 index1) + (seq-elt sequence2 index2)) + return (1+ index1)) + + (do* ((i1 start1 (1+ i1)) + (i2 start2 (1+ i2)) + x1 x2) + ((and (>= i1 (seq-length sequence1)) + (>= i2 (seq-length sequence2))) nil) + (if (>= i1 (seq-length sequence1)) (return i1)) + (if (>= i2 (seq-length sequence2)) (return i1)) + (setq x1 (seq-elt sequence1 i1)) + (setq x2 (seq-elt sequence2 i2)) + (unless (eql x1 x2) + (return i1)))))) + +(defun synchronize-drei-buffer (stream) + "If the `input-buffer-array' of `stream' is non-NIL, copy the +contents of the array to the Drei buffer. This will set the +contents of the buffer to the contents of the array up to the +fill pointer." (with-accessors ((array input-buffer-array)) stream (let ((buffer (buffer (drei-instance stream)))) (when array ;; Attempt to minimise the changes to the buffer, so the ;; position of marks will not be changed too much. Find the ;; first mismatch between buffer contents and array contents. - (let ((index (loop - for index from 0 below (min (length array) - (size buffer)) - unless (eql (buffer-object buffer index) - (aref array index)) - do (return index) - finally (return nil))) - (insertion-pointer (stream-insertion-pointer stream))) - (when index ; NIL if buffer and array are identical. - ;; Delete from the first mismatch to the end of the buffer. - (delete-buffer-range buffer index - (- (size buffer) index)) - ;; Insert from the mismatch to array end into the buffer. - (insert-buffer-sequence buffer index - (subseq array index)) - ;; We also need to update the syntax. - (update-syntax buffer (syntax buffer)) - ;; Finally, see if it is possible to maintain the old - ;; position of the insertion pointer. - (setf (stream-insertion-pointer stream) - (min insertion-pointer (size buffer))))) - (setf array nil))))) + (multiple-value-bind (index buffer-end array-end) + (let* ((buffer-array-mismatch-begin (or (buffer-array-mismatch + buffer array) + 0)) + (buffer-buffer-array-mismatch-end (or (buffer-array-mismatch + buffer array :from-end t + :start2 buffer-array-mismatch-begin) + buffer-array-mismatch-begin)) + (array-buffer-array-mismatch-end (or (buffer-array-mismatch + array buffer :from-end t + :start2 buffer-array-mismatch-begin) + buffer-array-mismatch-begin))) + (values buffer-array-mismatch-begin + (max buffer-buffer-array-mismatch-end buffer-array-mismatch-begin) + (max array-buffer-array-mismatch-end buffer-array-mismatch-begin))) + (let ((insertion-pointer (stream-insertion-pointer stream))) + (when index ; NIL if buffer and array are identical. + ;; Delete from the first mismatch to the end of the + ;; mismatch. + (delete-buffer-range buffer index (- buffer-end index)) + ;; Also delete from the end of the buffer if the array + ;; is smaller than the buffer. + (when (> (size buffer) (length array)) + (delete-buffer-range buffer (length array) + (- (size buffer) + (length array)))) + ;; Insert from the mismatch to end mismatch from the + ;; array into the buffer. + (insert-buffer-sequence buffer index (subseq array index array-end)) + ;; We also need to update the syntax. + (update-syntax buffer (syntax buffer)) + ;; Finally, see if it is possible to maintain the old + ;; position of the insertion pointer. + (setf (stream-insertion-pointer stream) + (min insertion-pointer (size buffer)))))))))) + +(defun synchronize-input-buffer-array (stream) + "If the `input-buffer-array' of `stream' is non-NIL, copy the +contents of the Drei buffer to the array. The fill pointer of the +array will point to after the last element." + (with-accessors ((array input-buffer-array)) stream + (let ((buffer (buffer (drei-instance stream)))) + (when array + (let ((new-array (buffer-sequence buffer 0 (size buffer)))) + (setf array + ;; We probably lose if `adjust-array' doesn't + ;; destructively modify `array. + (adjust-array array (length new-array) + :initial-contents new-array + :fill-pointer (length new-array)))))))) + +(defun update-drei-buffer (stream) + "Update the Drei buffer of the Drei instance used by `stream' +if the `input-buffer-array' of `stream' is non-NIl. This will set +the contents of the buffer to the contents of the array up to the +fill pointer. Changes to the buffer will be recordes as +undoable. When this function returns, the `input-buffer-array' of +`stream' will be NIL. Also, the syntax will be up-to-date." + (with-undo ((list (buffer (drei-instance stream)))) + (synchronize-drei-buffer stream)) + (setf (input-buffer-array stream) nil)) ;; While the CLIM spec says that user-commands are not allowed to do ;; much with the input buffer, the Franz User Guide provides some @@ -224,13 +299,11 @@ ;; NOTE: This is very slow (consing up a whole new array - twice!), ;; please do not use it unless you want to be compatible with other ;; editor substrates. Use the Drei buffer directly instead. - (or (input-buffer-array stream) - (setf (input-buffer-array stream) - (with-accessors ((buffer buffer)) (drei-instance stream) - (let* ((array (buffer-sequence buffer 0 (size buffer)))) - (make-array (length array) - :fill-pointer (length array) - :initial-contents array)))))) + (unless (input-buffer-array stream) + ;; Create dummy array and synchronize it to the buffer contents. + (setf (input-buffer-array stream) (make-array 0 :fill-pointer 0)) + (synchronize-input-buffer-array stream)) + (input-buffer-array stream)) (defmethod replace-input ((stream drei-input-editing-mixin) (new-input array) &key @@ -241,6 +314,13 @@ (check-type start integer) (check-type end integer) (check-type buffer-start integer) + ;; Since this is a CLIM-specified function, we have to make sure the + ;; input-buffer-array is taken into consideration, because some + ;; input-editor-command might call this function and expect the + ;; changes to be reflected in the array it holds. Also, if changes + ;; have been made to the array, they need to be propagated to the + ;; buffer before we do anything. + (synchronize-drei-buffer stream) (let* ((drei (drei-instance stream)) (new-contents (subseq new-input start end)) (old-contents (buffer-sequence (buffer drei) @@ -253,11 +333,16 @@ (unless equal (setf (offset begin-mark) buffer-start) (delete-region begin-mark (stream-scan-pointer stream)) - (insert-sequence begin-mark new-contents)) - (update-syntax (buffer drei) (syntax (buffer drei))) + (insert-sequence begin-mark new-contents) + (update-syntax (buffer drei) (syntax (buffer drei))) + ;; Make the buffer reflect the changes in the array. + (synchronize-input-buffer-array stream)) (display-drei drei) (when (or rescan (not equal)) - (queue-rescan stream))))) + (queue-rescan stream)) + ;; We have to return "the position in the input buffer". We + ;; return the insertion position. + buffer-start))) (defun present-acceptably-to-string (object type view for-context-type) "Return two values - a string containing the printed @@ -608,14 +693,17 @@ (declare (ignore start-position)) ;; We ignore `start-position', because it would be more work to ;; figure out what to redraw than to just redraw everything. + ;; We assume that this function is mostly called from non-Drei-aware + ;; code, and thus synchronise the input-editor-array with the Drei + ;; buffer before redisplaying. + (update-drei-buffer stream) (display-drei (drei-instance stream))) (defmethod erase-input-buffer ((stream drei-input-editing-mixin) &optional (start-position 0)) (declare (ignore start-position)) - ;; Again, we ignore `start-position'. What is the big idea behind - ;; this function anyway? - (clear-output-record (drei-instance stream))) + ;; No-op, just to save older CLIM programs from dying. + nil) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;;

1 0

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

06 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv9653 Modified Files: input-editor.lisp Log Message: Try to handle "partially readable" objects. --- /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/01 23:02:59 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/input-editor.lisp 2006/12/06 13:00:00 1.10 @@ -304,6 +304,56 @@ printed-rep) args)))) +;; The purpose of this method is to ensure that things such as lists +;; should are not completely inserted as literal objects if they have +;; unreadable elements. +(defmethod presentation-replace-input + ((stream drei-input-editing-mixin) object (type (eql 'expression)) view + &rest args &key + (buffer-start (input-position stream)) rescan + query-identifier (for-context-type type)) + (declare (ignore query-identifier rescan for-context-type buffer-start)) + ;; Build up an array, `insertion', and use `replace-input' to insert + ;; it. + (let ((insertion (make-array 10 :adjustable t :fill-pointer 0))) + (labels ((insert-object (object) + (vector-push-extend object insertion + (* (length insertion)))) + (insert-objects (objects) + (setf insertion (adjust-array insertion + (+ (length insertion) + (length objects)) + :fill-pointer (+ (fill-pointer insertion) + (length objects)))) + (setf (subseq insertion (- (fill-pointer insertion) + (length objects))) objects)) + (present-object (object) + (multiple-value-bind (printed-rep accept-object) + (present-acceptably-to-string object 'expression + +textual-view+ 'expression) + (if (null accept-object) + (insert-objects printed-rep) + (typecase object + (list (insert-list-in-stream object)) + (array (insert-object #\#) + (insert-list-in-stream object)) + (function (let ((name (nth-value 2 (function-lambda-expression object)))) + (insert-objects (or (format nil "#'~A" name) + (vector object))))) + ;; Okay, we give up, just insert it. + (t (insert-object object))))))) + (present-object object)) + (with-keywords-removed (args (:type :view :query-identifier :for-context-type)) + (apply #'replace-input stream insertion args)))) + +(defmethod presentation-replace-input + ((stream drei-input-editing-mixin) object (type (eql 'form)) view + &rest args &key + (buffer-start (input-position stream)) rescan + query-identifier (for-context-type type)) + (declare (ignore query-identifier rescan for-context-type buffer-start)) + (apply #'presentation-replace-input stream object 'expression view args)) + (defvar *drei-input-editing-stream* nil "Used to provide CLIM-specified input-editing-commands with the input-editing-stream. Bound when executing a command.")

1 0

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

06 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv26314 Modified Files: lisp-syntax.lisp Log Message: Somewhat-fixed `token-to-object's handling of backquote forms. Has been tested by repeatedly using `token-to-object' to convert lisp-syntax.lisp into lists and feeding them to `eval' (this calls out for a test case that recompiles Drei using code extracted with this method!) --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 19:20:47 1.10 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/06 11:31:12 1.11 @@ -1050,9 +1050,9 @@ ;;;;;;;;;;;;;;;; Comma ;;; parse trees -(defclass comma-form (form) ()) -(defclass comma-at-form (form) ()) -(defclass comma-dot-form (form) ()) +(defclass comma-form (form complete-form-mixin) ()) +(defclass comma-at-form (form complete-form-mixin) ()) +(defclass comma-dot-form (form complete-form-mixin) ()) (define-parser-state |, | (form-may-follow) ()) (define-parser-state |, form | (lexer-toplevel-state parser-state) ()) @@ -2477,25 +2477,21 @@ :case case :no-error t)) -(defgeneric token-to-object (syntax token &key no-error package quote read &allow-other-keys) +(defgeneric token-to-object (syntax token &key no-error package read backquoted &allow-other-keys) (:documentation "Return the Lisp object `token' would evaluate to if read. An attempt will be made to construct objects from incomplete tokens. This function may signal an error if `no-error' is nil and `token' cannot be converted to a Lisp object. Otherwise, nil will be returned.") - (:method :around (syntax (token t) &rest args &key - package quote no-error &allow-other-keys) + (:method :around (syntax (token t) &key package no-error &allow-other-keys) ;; Ensure that every symbol that is READ will be looked up ;; in the correct package. Also handle quoting. (flet ((act () (let ((*package* (or package (package-at-mark - syntax (start-offset token))))) - (cond (quote - (setf (getf args :quote) nil) - `',(call-next-method)) - (t - (call-next-method)))))) + syntax (start-offset token))))) + + (call-next-method)))) (if no-error (ignore-errors (act)) (act)))) @@ -2510,6 +2506,57 @@ (error "Cannot convert incomplete form to Lisp object: ~A" token)))) +;;; The complicated primary structure forms. + +;; The problem is that we can't portably create in-memory backquote +;; forms, so we have to rewrite them to calls to `nconc'. I think this +;; is valid, because the CLHS doesn't specify the in-memory +;; representation of backquoted forms, and thus the user can't assume +;; that it isn't just a whole bunch of calls to `nconc' anyway. +(defmethod token-to-object (syntax (token list-form) &rest args &key backquoted) + (if backquoted + `(nconc ,@(loop for child in (children token) + if (typep child 'comma-at-form) + collect (apply #'token-to-object syntax child :backquoted nil args) + else if (typep child 'comma-form) + collect `(list ,(apply #'token-to-object syntax child :backquoted nil args)) + else if (form-token-p child) + collect `(list ,`',(apply #'token-to-object syntax child args)) + else if (formp child) + collect `(list ,(apply #'token-to-object syntax child args)))) + (mapcar #'(lambda (child) + (apply #'token-to-object syntax child args)) + (remove-if-not #'formp (children token))))) + +(defmethod token-to-object (syntax (token complete-quote-form) &rest args &key backquoted) + (if backquoted + (let ((quoted-form (first-form (children token)))) + (if (form-token-p quoted-form) + `(list 'quote (quote ,(apply #'token-to-object syntax (second (children token)) args))) + `(list 'quote ,(apply #'token-to-object syntax (second (children token)) args)))) + `',(apply #'token-to-object syntax (second (children token)) args))) + +(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) + (declare (ignore args)) + ;; Utterly arbitrary, but reasonable in my opinion. + '(quote)) + +;; I'm not sure backquotes are handled correctly, but they should be, +;; at least when :read t is specified. +(defmethod token-to-object (syntax (token backquote-form) &rest args) + (let ((backquoted-form (first-form (children token)))) + (if (form-token-p backquoted-form) + `',(apply #'token-to-object syntax backquoted-form args) + (apply #'token-to-object syntax backquoted-form :backquoted t args)))) + +(defmethod token-to-object (syntax (token comma-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args)) + +(defmethod token-to-object (syntax (token comma-at-form) &rest args) + (apply #'token-to-object syntax (first-form (children token)) :backquoted nil args)) + +;;; The atom(-ish) forms. + (defmethod token-to-object (syntax (token complete-token-lexeme) &key no-error read (case (readtable-case *readtable*)) &allow-other-keys) @@ -2531,13 +2578,6 @@ (let ((*read-base* (base syntax))) (read-from-string (token-string syntax token)))) -(defmethod token-to-object (syntax (token list-form) &rest args) - (loop for child in (children token) - if (typep child 'comma-at-form) - nconc (listed (apply #'token-to-object syntax child args)) - else if (formp child) - collect (apply #'token-to-object syntax child args))) - (defmethod token-to-object (syntax (token simple-vector-form) &key &allow-other-keys) (apply #'vector (call-next-method))) @@ -2551,34 +2591,6 @@ (declare (ignore no-error)) (read-from-string (token-string syntax token))) -(defmethod token-to-object (syntax (token complete-quote-form) &rest args) - (apply #'token-to-object syntax (second (children token)) :quote t args)) - -(defmethod token-to-object (syntax (token incomplete-quote-form) &rest args) - (declare (ignore args)) - ;; Utterly arbitrary, but reasonable in my opinion. - '(quote)) - -;; I'm not sure backquotes are handled correctly, but they should be, -;; at least when :read t is specified. -(defmethod token-to-object (syntax (token backquote-form) &rest args) - (let ((backquoted-form (first-form (children token)))) - (if (form-list-p backquoted-form) - `(list ,@(loop for element in (children backquoted-form) - if (form-comma-p element) - collect (apply #'token-to-object syntax element args) - else if (form-comma-at-p element) - nconc (listed (apply #'token-to-object syntax element args)) - else if (formp element) - collect (apply #'token-to-object syntax element :quote t args))) - `',(apply #'token-to-object syntax backquoted-form args)))) - -(defmethod token-to-object (syntax (token comma-form) &rest args) - (apply #'token-to-object syntax (first-form (children token)) args)) - -(defmethod token-to-object (syntax (token comma-at-form) &rest args) - (apply #'token-to-object syntax (first-form (children token)) args)) - (defmethod token-to-object (syntax (token function-form) &rest args) (list 'cl:function (apply #'token-to-object syntax (second (children token)) args)))

1 0

[mcclim-cvs] CVS mcclim
by rgoldman 05 Dec '06

05 Dec '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11209 Modified Files: panes.lisp Log Message: Handle :both (clim 2.2) as synonym for t in :scroll-bars. --- /project/mcclim/cvsroot/mcclim/panes.lisp 2006/11/08 01:18:22 1.173 +++ /project/mcclim/cvsroot/mcclim/panes.lisp 2006/12/05 02:08:44 1.174 @@ -27,7 +27,7 @@ ;;; Free Software Foundation, Inc., 59 Temple Place - Suite 330, ;;; Boston, MA 02111-1307 USA. -;;; $Id: panes.lisp,v 1.173 2006/11/08 01:18:22 thenriksen Exp $ +;;; $Id: panes.lisp,v 1.174 2006/12/05 02:08:44 rgoldman Exp $ (in-package :clim-internals) @@ -1900,7 +1900,7 @@ (defparameter *scrollbar-thickness* 17) (defclass scroller-pane (composite-pane) - ((scroll-bar :type (member t :vertical :horizontal nil) + ((scroll-bar :type scroll-bar-spec ; (member t :vertical :horizontal nil) ;; ### Note: I added NIL here, so that the application ;; programmer can switch off scroll bars alltogether. ;; The spec though has it neither in the description of @@ -2091,8 +2091,9 @@ (when (first (sheet-children viewport)) (setf (slot-value pane 'background) ;### hmm ... (pane-background (first (sheet-children viewport))))) - ;; - (when (member scroll-bar '(:vertical t)) + ;; make sure that we have ok options for the scroll-bar argument... + (check-type scroll-bar scroll-bar-spec) ; (member :vertical :horizontal :both t nil)) + (when (member scroll-bar '(:vertical :both t)) (setq vscrollbar (make-pane 'scroll-bar-pane :orientation :vertical @@ -2118,7 +2119,7 @@ :min-value 0 :max-value 1)) (sheet-adopt-child pane vscrollbar)) - (when (member scroll-bar '(:horizontal t)) + (when (member scroll-bar '(:horizontal :both t)) (setq hscrollbar (make-pane 'scroll-bar-pane :orientation :horizontal @@ -2430,7 +2431,7 @@ mouse-wheel-scroll-mixin cut-and-paste-mixin) ((redisplay-needed :initarg :display-time) - (scroll-bars :type (member t :vertical :horizontal nil) + (scroll-bars :type scroll-bar-spec ; (member t :vertical :horizontal nil) :initform nil :initarg :scroll-bars :accessor pane-scroll-bars)

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv11335/Drei Modified Files: drei-clim.lisp Log Message: Patch from rpg: now handle both CLIM 2.2 and CLIM 2.0-style scroller options. --- /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/11/24 22:43:03 1.12 +++ /project/mcclim/cvsroot/mcclim/Drei/drei-clim.lisp 2006/12/04 22:31:18 1.13 @@ -403,7 +403,7 @@ (drei-class 'drei-gadget-pane)) (check-type initial-contents array) (check-type border-width integer) - (check-type scroll-bars (member :vertical :horizontal t nil)) + (check-type scroll-bars (member t :both :vertical :horizontal nil)) (with-keywords-removed (args (:minibuffer :scroll-bars :border-width :syntax)) (let* ((borderp (and border-width (plusp border-width))) (minibuffer-pane (cond ((eq minibuffer t)

1 0

[mcclim-cvs] CVS mcclim
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv11335 Modified Files: decls.lisp Log Message: Patch from rpg: now handle both CLIM 2.2 and CLIM 2.0-style scroller options. --- /project/mcclim/cvsroot/mcclim/decls.lisp 2006/11/22 14:15:53 1.41 +++ /project/mcclim/cvsroot/mcclim/decls.lisp 2006/12/04 22:31:19 1.42 @@ -696,6 +696,8 @@ (defgeneric pane-scroller (pane)) (defgeneric scroll-extent (pane x y)) +(deftype scroll-bar-spec () '(member t :both :vertical :horizontal nil)) + ;;;; 29.3.4 The Layout Protocol ;; (define-protocol-class space-requirement ())

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv22078 Modified Files: lisp-syntax-swine.lisp lisp-syntax-commands.lisp Log Message: Using #\Tab for completing Lisp symbols will no longer potentially cause you to be presented with a list of every symbol in the package. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/11/14 12:27:53 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-swine.lisp 2006/12/04 20:07:53 1.3 @@ -997,61 +997,69 @@ (best (caar set))) (values best set))) -(defun complete-symbol-at-mark-with-fn (syntax mark &optional (fn #'find-completions)) +(defun complete-symbol-at-mark-with-fn (syntax mark &key (completion-finder #'find-completions) + (complete-blank t)) "Attempt to find and complete the symbol at `mark' using the - function `fn' to get the list of completions. If the completion + function `completion-finder' to get the list of completions. If the completion is ambiguous, a list of possible completions will be - displayed. If no symbol can be found at `mark', return nil." + 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." (let* ((token (form-around syntax (offset mark))) (useful-token (and (not (null token)) (form-token-p token) (not (= (start-offset token) (offset mark)))))) - (multiple-value-bind (longest completions) - (funcall fn syntax - (if useful-token - (start-offset (fully-quoted-form token)) - (if (and (form-quoted-p token) - (form-incomplete-p token)) - (start-offset token) - (offset mark))) - (if useful-token - (token-string syntax token) - "")) - (if completions - (if (= (length completions) 1) - (replace-symbol-at-mark mark syntax longest) - (progn - (esa:display-message (format nil "Longest is ~a|" longest)) - (let ((selection (menu-choose (mapcar - ;; FIXME: this can - ;; get ugly. - #'(lambda (completion) - (if (listp completion) - (cons completion - (first completion)) - completion)) - completions) - :label "Possible completions" - :scroll-bars :vertical))) - (if useful-token - (replace-symbol-at-mark mark syntax (or selection longest)) - (insert-sequence mark (or selection longest)))))) - (esa:display-message "No completions found"))) - t)) + (when (or useful-token complete-blank) + (multiple-value-bind (longest completions) + (funcall completion-finder syntax + (if useful-token + (start-offset (fully-quoted-form token)) + (if (and (form-quoted-p token) + (form-incomplete-p token)) + (start-offset token) + (offset mark))) + (if useful-token + (token-string syntax token) + "")) + (if completions + (if (= (length completions) 1) + (replace-symbol-at-mark mark syntax longest) + (progn + (esa:display-message (format nil "Longest is ~a|" longest)) + (let ((selection (menu-choose (mapcar + ;; FIXME: this can + ;; get ugly. + #'(lambda (completion) + (if (listp completion) + (cons completion + (first completion)) + completion)) + completions) + :label "Possible completions" + :scroll-bars :vertical))) + (if useful-token + (replace-symbol-at-mark mark syntax (or selection longest)) + (insert-sequence mark (or selection longest))) + t))) + (esa:display-message "No completions found")))))) -(defun complete-symbol-at-mark (syntax mark) +(defun complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark'. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark)) + (complete-symbol-at-mark-with-fn syntax mark :complete-blank complete-blank)) -(defun fuzzily-complete-symbol-at-mark (syntax mark) +(defun fuzzily-complete-symbol-at-mark (syntax mark &optional (complete-blank t)) "Attempt to find and complete the symbol at `mark' using fuzzy completion. If the completion is ambiguous, a list of possible completions will be displayed. If no symbol can be found at `mark', return nil." - (complete-symbol-at-mark-with-fn syntax mark #'find-fuzzy-completions)) + (complete-symbol-at-mark-with-fn syntax mark + :completion-finder #'find-fuzzy-completions + :complete-blank complete-blank)) ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; ;;; --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/11/14 12:27:53 1.2 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax-commands.lisp 2006/12/04 20:07:53 1.3 @@ -125,29 +125,26 @@ (forward-object mark) (clear-completions))) -(define-command (com-complete-symbol :name t :command-table lisp-table) () +(define-command (com-complete-symbol :name t :command-table lisp-table) + () "Attempt to complete the symbol at mark. If successful, move point to end of symbol. -If more than one completion is available, a list of -possible completions will be displayed." - (let* ((pane *current-window*) - (buffer (buffer pane)) - (syntax (syntax buffer)) - (mark (point pane))) - (complete-symbol-at-mark syntax mark))) +If more than one completion is available, a list of possible +completions will be displayed. If there is no symbol at mark, all +relevant symbols accessible in the current package will be +displayed." + (complete-symbol-at-mark *current-syntax* *current-mark*)) -(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) () +(define-command (com-fuzzily-complete-symbol :name t :command-table lisp-table) + () "Attempt to fuzzily complete the abbreviation at mark. Fuzzy completion tries to guess which symbol is abbreviated. If the abbreviation is ambiguous, a list of possible completions -will be displayed." - (let* ((pane *current-window*) - (buffer (buffer pane)) - (syntax (syntax buffer)) - (mark (point pane))) - (fuzzily-complete-symbol-at-mark syntax mark))) +will be displayed. If there is no symbol at mark, all relevant +symbols accessible in the current package will be displayed." + (fuzzily-complete-symbol-at-mark *current-syntax* *current-mark*)) (define-command (com-indent-line-and-complete-symbol :name t :command-table lisp-table) () "Indents the current line and performs symbol completion. @@ -162,7 +159,7 @@ (offset point)) (let* ((buffer (buffer pane)) (syntax (syntax buffer))) - (or (complete-symbol-at-mark syntax point) + (or (complete-symbol-at-mark syntax point nil) (show-arglist-for-form-at-mark point syntax)))))) (define-presentation-to-command-translator lookup-symbol-arglist

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12357 Modified Files: kill-ring.lisp Log Message: Added explicit `defgeneric's. --- /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/11/28 23:34:10 1.3 +++ /project/mcclim/cvsroot/mcclim/Drei/kill-ring.lisp 2006/12/04 19:22:02 1.4 @@ -24,6 +24,14 @@ (in-package :drei-kill-ring) +(defgeneric kill-ring-chain (ring) + (:documentation "Return the cursorchain associated with the +kill ring `ring'.")) + +(defgeneric kill-ring-cursor (ring) + (:documentation "Return the flexicursor associated with the +kill ring.")) + (defclass kill-ring () ((max-size :type (integer 5 *) ;5 element minimum from flexichain protocol :initarg :max-size

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv12188 Modified Files: lisp-syntax.lisp Log Message: Backward Up was broken, now it isn't, I hope. I admit that I have no idea what that condition I removed was supposed to do, since `formp' will be T for anything it's ever going to be called with. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 18:12:38 1.9 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 19:20:47 1.10 @@ -2142,18 +2142,17 @@ (form-around-in-children (children stack-top) offset)))) (defun find-list-parent-offset (form fn) - "Find a list parent of `token' and return `fn' + "Find a list parent of `token' 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 `fn' applied to `form'." - (when (not (formp form)) - (let ((parent (parent form))) - (typecase parent - (form* (funcall fn form)) - (list-form (funcall fn form)) - (null (funcall fn form)) - (t (find-list-parent-offset parent fn)))))) + (let ((parent (parent form))) + (typecase parent + (form* (funcall fn form)) + (list-form (funcall fn form)) + (null (funcall fn form)) + (t (find-list-parent-offset parent fn))))) (defun find-list-child-offset (form fn &optional (min-offset 0)) "Find a list child of `token' with a minimum start @@ -2250,11 +2249,11 @@ (form-after syntax (offset mark)) (form-around syntax (offset mark))))) (when form - (let ((parent (parent form))) - (when (not (null parent)) - (let ((new-offset (find-list-parent-offset parent fn))) - (when new-offset - (setf (offset mark) new-offset)))))))) + (let ((parent (parent form))) + (when (not (null parent)) + (let ((new-offset (find-list-parent-offset parent fn))) + (when new-offset + (setf (offset mark) new-offset)))))))) (defmethod backward-one-up (mark (syntax lisp-syntax)) (up-list-by-fn mark syntax #'start-offset))

1 0

[mcclim-cvs] CVS mcclim/Drei
by thenriksen 04 Dec '06

04 Dec '06

Update of /project/mcclim/cvsroot/mcclim/Drei In directory clnet:/tmp/cvs-serv31244 Modified Files: lisp-syntax.lisp Log Message: Hack together a solution for the bug reported by Robert Strand on mcclim-devel. I'm not pretty sure the `token-to-object' function is insufficient for properly handling the evil of backquoting. It'll have to be revised at some point. --- /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/02 20:28:18 1.8 +++ /project/mcclim/cvsroot/mcclim/Drei/lisp-syntax.lisp 2006/12/04 18:12:38 1.9 @@ -2535,7 +2535,7 @@ (defmethod token-to-object (syntax (token list-form) &rest args) (loop for child in (children token) if (typep child 'comma-at-form) - append (apply #'token-to-object syntax child args) + nconc (listed (apply #'token-to-object syntax child args)) else if (formp child) collect (apply #'token-to-object syntax child args))) @@ -2567,11 +2567,11 @@ (if (form-list-p backquoted-form) `(list ,@(loop for element in (children backquoted-form) if (form-comma-p element) - collect (apply #'token-to-object syntax element args) + collect (apply #'token-to-object syntax element args) else if (form-comma-at-p element) - nconc (apply #'token-to-object syntax element args) + nconc (listed (apply #'token-to-object syntax element args)) else if (formp element) - collect (apply #'token-to-object syntax element :quote t args))) + collect (apply #'token-to-object syntax element :quote t args))) `',(apply #'token-to-object syntax backquoted-form args)))) (defmethod token-to-object (syntax (token comma-form) &rest args)

1 0

Jump to page:

2024

2023

2022

2021

2020

2019

2018

2017

2016

2015

2014

2013

2012

2011

2010

2009

2008

2007

2006

2005

2004

mcclim-cvs