[Linedit-cvs] CVS update: src/main.lisp src/packages.lisp src/sbcl-repl.lisp src/utility-functions.lisp

[Nikodemus Siivola]

Update of /project/linedit/cvsroot/src
In directory common-lisp.net:/tmp/cvs-serv11544

Modified Files:
	main.lisp packages.lisp sbcl-repl.lisp utility-functions.lisp 
Log Message:
- Added :eof-quits keyword to install-repl.
- Various formedit and repl fixes.

Date: Thu Nov 20 12:29:55 2003
Author: nsiivola

Index: src/main.lisp
diff -u src/main.lisp:1.8 src/main.lisp:1.9
--- src/main.lisp:1.8	Sun Nov  9 08:20:39 2003
+++ src/main.lisp	Thu Nov 20 12:29:55 2003
@@ -35,21 +35,31 @@
 (defun formedit (&rest args &key (prompt1 "") (prompt2 "")
 		 &allow-other-keys)
   "Reads a single form of input with line-editing. Returns the form as
-a string.  Not realiable in the presense of customized readtable
-functinality."
+a string. Assumes standard readtable."
   (let ((args (copy-list args)))
     (dolist (key '(:prompt1 :prompt2))
       (remf args key))
     (catch 'form-done
-      (let ((eof-marker (list nil))
-	    (table (copy-readtable *readtable*)))
+      (let ((eof-marker (gensym "EOF"))
+	    (table (copy-readtable)))
+	(set-macro-character #\; #'semicolon-reader nil table)
 	(set-dispatch-macro-character #\# #\. (constantly (values)) table)
 	(do ((str (apply #'linedit :prompt prompt1 args)
 		  (concat str
 			  (string #\newline)
 			  (apply #'linedit :prompt prompt2 args))))
 	    ((let ((form (handler-case (let ((*readtable* table))
-					 (read-from-string str))
-			   (end-of-file () eof-marker))))
+					 ;; Eugh. Argh.
+					 (if (find-if-not 'whitespacep str)
+					     (read-from-string str)
+					     (error 'end-of-file)))
+			   (end-of-file () 
+			     eof-marker))))
 	       (unless (eq eof-marker form)
 		 (throw 'form-done str)))))))))
+
+(defun semicolon-reader (stream char)
+  (declare (ignore char))
+  (loop for char = (read-char stream)
+	until (eql char #\newline))
+  (values))


Index: src/packages.lisp
diff -u src/packages.lisp:1.12 src/packages.lisp:1.13
--- src/packages.lisp:1.12	Sat Nov  1 15:35:42 2003
+++ src/packages.lisp	Thu Nov 20 12:29:55 2003
@@ -29,3 +29,7 @@
    #+sbcl #:install-repl
    #+sbcl #:uninstall-repl
    ))
+
+
+
+


Index: src/sbcl-repl.lisp
diff -u src/sbcl-repl.lisp:1.5 src/sbcl-repl.lisp:1.6
--- src/sbcl-repl.lisp:1.5	Sat Nov  1 15:43:37 2003
+++ src/sbcl-repl.lisp	Thu Nov 20 12:29:55 2003
@@ -42,7 +42,7 @@
 	  (warn "UNINSTALL-REPL failed: No Linedit REPL present."))
       nil)
 
-    (defun install-repl (&key wrap-current)
+    (defun install-repl (&key wrap-current eof-quits)
       "Installs the Linedit at REPL. Original input handlers can be
 preserved with the :WRAP-CURRENT T."
       (enforce-consistent-state)
@@ -62,19 +62,27 @@
 		      :prompt1 prompt
 		      :prompt2 (make-string (length prompt) 
 					    :initial-element #\Space))
-		   (end-of-file () (sb-ext:quit))))))
+		   (end-of-file (e)
+		     (if eof-quits
+			 (and (fresh-line) (sb-ext:quit))
+			 ;; Hackins, I know.
+			 "#.''end-of-file"))))))
 	(setf sb-int:*repl-prompt-fun* (constantly ""))
 	(setf sb-int:*repl-read-form-fun*	      
 	      (if wrap-current
 		  (lambda (in out)
 		    (declare (type stream out in))
+		      ;; FIXME: Yich.
+		    (terpri)
 		    (with-input-from-string (in (repl-reader in out))
-		      ;; FIXME: Youch.
-		      (write-char #\newline)
-		      (write-char #\return)
 		      (funcall read-form-fun in out)))
 		  (lambda (in out)
 		    (declare (type stream out in))
-		    (read-from-string (repl-reader in out))))))
+		    (handler-case (read-from-string (repl-reader in out))
+		      (end-of-file () 
+			;; We never get here if eof-quits is true, so...
+			(fresh-line)
+			(write-line "#<end-of-file>")
+			(values)))))))
       t)))
 	  


Index: src/utility-functions.lisp
diff -u src/utility-functions.lisp:1.4 src/utility-functions.lisp:1.5
--- src/utility-functions.lisp:1.4	Sun Nov  9 07:28:03 2003
+++ src/utility-functions.lisp	Thu Nov 20 12:29:55 2003
@@ -28,12 +28,15 @@
   (error "Required argument missing."))
 
 (defun concat (&rest strings)
-  (apply #'concatenate 'string strings))
+  (apply #'concatenate 'simple-string strings))
 
 (defun word-delimiter-p (char)
-  (declare (string *word-delimiters*)
+  (declare (simple-string *word-delimiters*)
 	   (character char))
   (find char *word-delimiters*))
 
 (defun make-whitespace (n)
   (make-string n :initial-element #\space))
+
+(defun whitespacep (char)
+  (member char '(#\space #\newline #\tab #\return #\page)))