Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv9153/src/core Modified Files: htext2.lisp Log Message: Make %print-before-mark and %print-after-mark always work, even on open lines. Date: Wed Dec 15 13:13:26 2004 Author: crhodes Index: phemlock/src/core/htext2.lisp diff -u phemlock/src/core/htext2.lisp:1.3 phemlock/src/core/htext2.lisp:1.4 --- phemlock/src/core/htext2.lisp:1.3 Tue Aug 10 14:47:07 2004 +++ phemlock/src/core/htext2.lisp Wed Dec 15 13:13:26 2004 @@ -5,7 +5,7 @@ ;;; Carnegie Mellon University, and has been placed in the public domain. ;;; #+CMU (ext:file-comment - "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.3 2004/08/10 12:47:07 rstrandh Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext2.lisp,v 1.4 2004/12/15 12:13:26 crhodes Exp $") ;;; ;;; ********************************************************************** ;;; @@ -371,47 +371,49 @@ (defun %print-before-mark (mark stream) (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :end charpos)) - (t - (write-string open-chars stream :end left-open-pos) - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start right-open-pos - :end p))))) - (t - (write-string chars stream :end charpos)))) + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :end charpos)) + (t + (write-string open-chars stream :end left-open-pos) + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start right-open-pos + :end p))))) + (t (let ((chars (line-chars line)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + (t + (write-string chars stream :end charpos))))))) (write-string "{deleted mark}" stream))) (defun %print-after-mark (mark stream) (if (mark-line mark) - (let* ((line (mark-line mark)) - (chars (line-chars line)) - (charpos (mark-charpos mark)) - (length (line-length line))) - (declare (simple-string chars)) - (cond ((or (> charpos length) (< charpos 0)) - (write-string "{bad mark}" stream)) - ((eq line open-line) - (cond ((< charpos left-open-pos) - (write-string open-chars stream :start charpos - :end left-open-pos) - (write-string open-chars stream :start right-open-pos - :end line-cache-length)) - (t - (let ((p (+ charpos (- right-open-pos left-open-pos)))) - (write-string open-chars stream :start p - :end line-cache-length))))) - (t - (write-string chars stream :start charpos :end length)))) + (let ((line (mark-line mark)) + (charpos (mark-charpos mark))) + (cond + ((eq line open-line) + (cond ((< charpos left-open-pos) + (write-string open-chars stream :start charpos + :end left-open-pos) + (write-string open-chars stream :start right-open-pos + :end line-cache-length)) + (t + (let ((p (+ charpos (- right-open-pos left-open-pos)))) + (write-string open-chars stream :start p + :end line-cache-length))))) + (t (let ((chars (line-chars line)) + (length (line-length line))) + (declare (simple-string chars)) + (cond ((or (> charpos length) (< charpos 0)) + (write-string "{bad mark}" stream)) + (t + (write-string chars stream :start charpos :end length))))))) (write-string "{deleted mark}" stream))) (defmethod print-object ((structure line) stream)