Update of /project/mcclim/cvsroot/mcclim In directory clnet:/tmp/cvs-serv24668

Modified Files: presentation-defs.lisp Log Message: Fix the utterly broken ACCEPT-FROM-STRING to at least work for common cases.

Still WIP.

--- /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/02/01 17:02:55 1.75 +++ /project/mcclim/cvsroot/mcclim/presentation-defs.lisp 2008/04/19 07:51:22 1.76 @@ -964,6 +964,102 @@ (declare (ignore type view other-args)) nil)

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

(define-presentation-generic-function %presentation-refined-position-test presentation-refined-position-test