[movitz-cvs] CVS update: movitz/losp/los0.lisp

[Frode Vatvedt Fjeld]

Update of /project/movitz/cvsroot/movitz/losp
In directory common-lisp.net:/tmp/cvs-serv24325

Modified Files:
	los0.lisp 
Log Message:
Tweaked the implementation of :more.

Date: Mon Jul 12 01:41:23 2004
Author: ffjeld

Index: movitz/losp/los0.lisp
diff -u movitz/losp/los0.lisp:1.17 movitz/losp/los0.lisp:1.18
--- movitz/losp/los0.lisp:1.17	Mon Jul 12 01:00:06 2004
+++ movitz/losp/los0.lisp	Mon Jul 12 01:41:23 2004
@@ -9,7 +9,7 @@
 ;;;; Created at:    Fri Dec  1 18:08:32 2000
 ;;;; Distribution:  See the accompanying file COPYING.
 ;;;;                
-;;;; $Id: los0.lisp,v 1.17 2004/07/12 08:00:06 ffjeld Exp $
+;;;; $Id: los0.lisp,v 1.18 2004/07/12 08:41:23 ffjeld Exp $
 ;;;;                
 ;;;;------------------------------------------------------------------
 
@@ -808,20 +808,32 @@
 (defmacro with-paging (options &body body)
   (declare (ignore options))
   `(block paging
-     (let ((*paging-offset* 2))
+     (let ((paging-offset 2))
        (handler-bind
 	   ((newline (lambda (condition)
 		       (declare (ignore condition))
-		       (when (>= (incf *paging-offset*)
-				 muerte.x86-pc::*screen-height*)
-			 (format t "~&more? ")
-			 (loop
+		       (when (and paging-offset
+				  (>= (incf paging-offset)
+				      muerte.x86-pc::*screen-height*))
+			 (format t "~&more? (y/n/a) ")
+			 (prog ()
+			  loop
 			   (case (muerte.x86-pc.keyboard:poll-char)
-			     ((#\esc #\n #\N)
+			     ((#\esc)
+			      (break "Console pager"))
+			     ((#\n #\N)	; No more
 			      (return-from paging (values)))
-			     ((#\y #\Y #\space #\newline)
-			      (setf *paging-offset* 1)
-			      (return))))))))
+			     ((#\a #\A)	; Quit paging
+			      (setf paging-offset nil))
+			     ((#\newline #\x)
+			      (setf paging-offset
+				(1- muerte.x86-pc::*screen-height*)))
+			     ((#\y #\Y #\space) ; One more page
+			      (setf paging-offset 1))
+			     (t (go loop))))
+			 (write-char #\return)
+			 (clear-line *standard-output* 0 (cursor-y *standard-output*))
+			 ))))
 	 , at body))))
 
 (defun tp (x) (dotimes (i x) (print i)))