[Phemlock-cvs] CVS update: phemlock/src/core/charmacs.lisp phemlock/src/core/htext3.lisp phemlock/src/core/htext4.lisp phemlock/src/core/macros.lisp
Gilbert Baumann
gbaumann at common-lisp.net
Mon Dec 27 18:53:35 UTC 2004
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)
+ , at 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*))
More information about the Phemlock-cvs
mailing list