Update of /project/phemlock/cvsroot/phemlock/src/core In directory common-lisp.net:/tmp/cvs-serv1172/src/core
Modified Files: charmacs.lisp htext3.lisp htext4.lisp macros.lisp Log Message: half-way working undo Date: Mon Dec 27 19:53:31 2004 Author: gbaumann
Index: phemlock/src/core/charmacs.lisp diff -u phemlock/src/core/charmacs.lisp:1.1 phemlock/src/core/charmacs.lisp:1.2 --- phemlock/src/core/charmacs.lisp:1.1 Fri Jul 9 17:00:36 2004 +++ phemlock/src/core/charmacs.lisp Mon Dec 27 19:53:27 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/charmacs.lisp,v 1.1 2004/07/09 15:00:36 gbaumann Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/charmacs.lisp,v 1.2 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -81,13 +81,26 @@ :lower, :upper, or :both, and var is bound to each character in order as specified under character relations in the manual. When :both is specified, lowercase letters are processed first." + ;; ### Hmm, I added iso-latin-1 characters here, but this gets eaten + ;; by the ALPHA-CHAR-P in ALPHA-CHARS-LOOP. --GB 2004-11-20 (case kind (:both - `(progn (alpha-chars-loop ,var #\a #\z nil ,forms) - (alpha-chars-loop ,var #\A #\Z ,result ,forms))) + `(progn + (alpha-chars-loop ,var #\a #\z nil ,forms) + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (:lower - `(alpha-chars-loop ,var #\a #\z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\ß #\ö nil ,forms) + (alpha-chars-loop ,var #\ø #\ÿ nil ,forms) + (alpha-chars-loop ,var #\a #\z ,result ,forms) )) (:upper - `(alpha-chars-loop ,var #\A #\Z ,result ,forms)) + `(progn + (alpha-chars-loop ,var #\A #\Z nil ,forms) + (alpha-chars-loop ,var #\À #\Ö nil ,forms) + (alpha-chars-loop ,var #\Ø #\Þ ,result ,forms) )) (t (error "Kind argument not one of :lower, :upper, or :both -- ~S." kind))))
Index: phemlock/src/core/htext3.lisp diff -u phemlock/src/core/htext3.lisp:1.2 phemlock/src/core/htext3.lisp:1.3 --- phemlock/src/core/htext3.lisp:1.2 Fri Dec 24 00:58:28 2004 +++ phemlock/src/core/htext3.lisp Mon Dec 27 19:53:27 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/htext3.lisp,v 1.2 2004/12/23 23:58:28 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext3.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -164,7 +164,7 @@ (+ last-charpos (- this-charpos charpos))))) (setf (line-next previous) new-line previous new-line)))))))) -(defun ninsert-region (mark region) +(defmethod ninsert-region (mark region) "Inserts the given Region at the Mark, possibly destroying the Region. Region may not be a part of any buffer's region." (let* ((start (region-start region))
Index: phemlock/src/core/htext4.lisp diff -u phemlock/src/core/htext4.lisp:1.2 phemlock/src/core/htext4.lisp:1.3 --- phemlock/src/core/htext4.lisp:1.2 Fri Dec 24 00:58:29 2004 +++ phemlock/src/core/htext4.lisp Mon Dec 27 19:53:27 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/htext4.lisp,v 1.2 2004/12/23 23:58:29 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/htext4.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -64,7 +64,8 @@ (region-end *internal-temp-region*) mark) (setf (region-start *internal-temp-region*) mark (region-end *internal-temp-region*) other-mark)) - (delete-region *internal-temp-region*) t) + (delete-region *internal-temp-region*) + t) (t nil)))))))
Index: phemlock/src/core/macros.lisp diff -u phemlock/src/core/macros.lisp:1.2 phemlock/src/core/macros.lisp:1.3 --- phemlock/src/core/macros.lisp:1.2 Sat Sep 4 01:06:51 2004 +++ phemlock/src/core/macros.lisp Mon Dec 27 19:53:27 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/macros.lisp,v 1.2 2004/09/03 23:06:51 abakic Exp $") + "$Header: /project/phemlock/cvsroot/phemlock/src/core/macros.lisp,v 1.3 2004/12/27 18:53:27 gbaumann Exp $") ;;; ;;; ********************************************************************** ;;; @@ -541,6 +541,44 @@ displaying any current output after each line." (when (and (numberp height) (zerop height)) (editor-error "I doubt that you really want a window with no height")) + `(invoke-with-pop-up-display (lambda (,var) + ,@body) + ,buffer-name ,height)) + +(defun invoke-with-pop-up-display (cont buffer-name height) + (let ((cleanup-p nil) + (stream (get-random-typeout-info buffer-name height))) + (unwind-protect + (progn + (catch 'more-punt + (when height + ;; Test height since it may be supplied, but evaluate + ;; to nil. + (when height + (prepare-for-random-typeout stream height) + (setf cleanup-p t))) + (multiple-value-prog1 + (funcall cont stream) + (unless height + (prepare-for-random-typeout stream nil) + (setf cleanup-p t) + (device-random-typeout-full-more (device-hunk-device + (window-hunk + (random-typeout-stream-window stream))) + stream)) + (end-random-typeout stream))) + (setf cleanup-p nil)) + (when cleanup-p (random-typeout-cleanup stream))))) + +#|| +(defmacro with-pop-up-display ((var &key height (buffer-name "Random Typeout")) + &body body) + "Execute body in a context with var bound to a stream. Output to the stream + appears in the buffer named buffer-name. The pop-up display appears after + the body completes, but if you supply :height, the output is line buffered, + displaying any current output after each line." + (when (and (numberp height) (zerop height)) + (editor-error "I doubt that you really want a window with no height")) (let ((cleanup-p (gensym)) (stream (gensym))) `(let ((,cleanup-p nil) @@ -568,6 +606,7 @@ (end-random-typeout ,var)))) (setf ,cleanup-p nil)) (when ,cleanup-p (random-typeout-cleanup ,stream)))))) +||#
(declaim (special *random-typeout-ml-fields* *buffer-names*))