[Sbcl-commits] CVS: sbcl/contrib/sb-aclrepl repl.lisp,1.13,1.14 sb-aclrepl.asd,1.10,1.11

[Kevin R. <kev...@us...>]

Update of /cvsroot/sbcl/sbcl/contrib/sb-aclrepl
In directory sc8-pr-cvs1:/tmp/cvs-serv6705/contrib/sb-aclrepl

Modified Files:
	repl.lisp sb-aclrepl.asd 
Log Message:
0.8alpha.0.24:
   * sb-aclrepl/sb-aclrepl.asd: 
        - Work around 'eql method specialization optimization notes
   * sb-aclrepl:repl.lisp: 
        - Refactor read-cmd into small functions
        - Add relative history numbers, eg, `:-2'
        - Add history pattern match search, eg, `::foo'
        - Add optional redo query to history command, eg, `:24 ?'
         


Index: repl.lisp
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/repl.lisp,v
retrieving revision 1.13
retrieving revision 1.14
diff -u -d -r1.13 -r1.14
--- repl.lisp	27 Apr 2003 17:00:28 -0000	1.13
+++ repl.lisp	12 May 2003 04:40:31 -0000	1.14
@@ -86,6 +86,107 @@
 
 (defun read-cmd (input-stream)
   ;; Reads a command from the user and returns a user-cmd object
+  (let ((next-char (peek-char-non-whitespace input-stream)))
+    (cond
+      ((eql *command-char* next-char)
+       (dispatch-command-line input-stream))
+      ((eql #\newline next-char)
+       (read-char input-stream)
+       *null-cmd*)
+      ((eql :eof next-char)
+       *eof-cmd*)
+      (t
+       (let* ((eof (cons nil *eof-marker*))
+	      (form (read input-stream nil eof)))
+	 (if (eq form eof)
+	     *eof-cmd*
+	     (make-user-cmd :input form :func nil :hnum *cmd-number*)))))))
+
+(defun dispatch-command-line (input-stream)
+  "Processes an input line that starts with *command-char*"
+  (let* ((line (string-trim-whitespace (read-line input-stream)))
+	 (first-space-pos (position #\space line))
+	 (cmd-string (subseq line 1 first-space-pos))
+	 (cmd-args-string
+	  (if first-space-pos
+	      (string-trim-whitespace (subseq line first-space-pos))
+	      "")))
+    (declare (simple-string line))
+    (cond
+      ((or (zerop (length cmd-string))
+	   (whitespace-char-p (char cmd-string 0)))
+       *null-cmd*)
+      ((or (numberp (read-from-string cmd-string))
+	   (char= (char cmd-string 0) #\+)
+	   (char= (char cmd-string 0) #\-))
+       (process-cmd-numeric cmd-string cmd-args-string))
+      ((char= (char cmd-string 0) *command-char*)
+       (process-history-search (subseq cmd-string 1) cmd-args-string))
+      (t
+       (process-cmd-text cmd-string line cmd-args-string)))))
+
+(defun process-cmd-numeric (cmd-string cmd-args-string)
+  "Process a numeric cmd, such as ':123'"
+  (let* ((first-char (char cmd-string 0))
+	 (number-string (if (digit-char-p first-char)
+			    cmd-string
+			    (subseq cmd-string 1)))
+	 (is-minus (char= first-char #\-))
+	 (raw-number (read-from-string number-string))
+	 (number (if is-minus
+		     (- *cmd-number* raw-number)
+		     raw-number))
+	 (cmd (get-history number)))
+    (when (eq cmd *null-cmd*)
+      (return-from process-cmd-numeric
+	(make-user-cmd :func :history-error :input (read-from-string
+						    cmd-string))))
+    (maybe-return-history-cmd cmd cmd-args-string)))
+
+(defun maybe-return-history-cmd (cmd cmd-args-string)
+  (format *output* "~&~A" (user-cmd-input cmd))
+  (let ((dont-redo
+	 (when (and (stringp cmd-args-string)
+		    (plusp (length cmd-args-string))
+		    (char= #\? (char cmd-args-string 0)))
+	   (do ((line nil (read-line *input*)))
+	       ((and line (or (zerop (length line))
+			      (string-equal line "Y")
+			      (string-equal line "N")))
+		(when (string-equal line "N")
+		  t))
+	     (when line
+	       (format *output* "~&Type \"y\" for yes or \"n\" for no."))
+	     (format *output* "~&redo? [y] ")
+	     (force-output *output*)))))
+    (if dont-redo
+	*null-cmd*
+	(make-user-cmd :func (user-cmd-func cmd)
+		       :input (user-cmd-input cmd)
+		       :args (user-cmd-args cmd)
+		       :hnum *cmd-number*))))
+
+
+(defun find-history-matching-pattern (cmd-string)
+  "Return history item matching cmd-string or NIL if not found"
+  (dolist (his *history* nil)
+    (let* ((input (user-cmd-input his))
+	   (string-input (if (stringp input)
+			     input
+			     (write-to-string input))))
+      (when (search cmd-string string-input :test #'string-equal)
+	(return-from find-history-matching-pattern his)))))
+
+(defun process-history-search (pattern cmd-args-string)
+  (let ((cmd (find-history-matching-pattern pattern)))
+    (unless cmd
+      (format *output* "No match on history list with pattern ~S" pattern)
+      (return-from process-history-search *null-cmd*))
+    (maybe-return-history-cmd cmd cmd-args-string)))
+
+
+(defun process-cmd-text (cmd-string line cmd-args-string)
+  "Process a text cmd, such as ':ld a b c'"
   (flet ((parse-args (parsing args-string)
 	   (case parsing
 	     (:string
@@ -98,53 +199,16 @@
 		(loop as arg = (read string-stream nil eof)
 		      until (eq arg eof)
 		      collect arg))))))
-    (let ((next-char (peek-char-non-whitespace input-stream)))
-      (cond
-	((eql next-char *command-char*)
-	 (let* ((line (string-trim-whitespace (read-line input-stream)))
-		(first-space-pos (position #\space line))
-		(cmd-string (subseq line 1 first-space-pos))
-		(cmd-args-string
-		 (if first-space-pos
-		     (string-trim-whitespace (subseq line first-space-pos))
-		     "")))
-	   (declare (string line))
-	   (cond
-	     ((numberp (read-from-string cmd-string))
-	      (let ((cmd (get-history (read-from-string cmd-string))))
-		(if (eq cmd *null-cmd*)
-		    (make-user-cmd :func :history-error
-				   :input (read-from-string cmd-string))
-		    (make-user-cmd :func (user-cmd-func cmd)
-				    :input (user-cmd-input cmd)
-				    :args (user-cmd-args cmd)
-				    :hnum *cmd-number*))))
-	     ((or (zerop (length cmd-string))
-		  (whitespace-char-p (char cmd-string 0)))
-	      *null-cmd*)
-	     (t
-	      (let ((cmd-entry (find-cmd cmd-string)))
-		(if cmd-entry
-		    (make-user-cmd :func (cmd-table-entry-func cmd-entry)
-				   :input line
-				   :args (parse-args
-					  (cmd-table-entry-parsing cmd-entry)
-					   cmd-args-string)
-				   :hnum *cmd-number*)
-		    (make-user-cmd :func :cmd-error
-				   :input cmd-string)))))))
-	((eql next-char #\newline)
-	 (read-char input-stream)
-	 *null-cmd*)
-	((eql next-char :eof)
-	 *eof-cmd*)
-	(t
-	 (let* ((eof (cons nil *eof-marker*))
-		(form (read input-stream nil eof)))
-	   (if (eq form eof)
-	       *eof-cmd*
-	       (make-user-cmd :input form :func nil :hnum *cmd-number*))))))))
-
+    (let ((cmd-entry (find-cmd cmd-string)))
+      (unless cmd-entry
+	(return-from process-cmd-text
+	  (make-user-cmd :func :cmd-error :input cmd-string)))
+      (make-user-cmd :func (cmd-table-entry-func cmd-entry)
+		     :input line
+		     :args (parse-args (cmd-table-entry-parsing cmd-entry)
+				       cmd-args-string)
+		     :hnum *cmd-number*))))
+  
 (defun make-cte (name-param func desc parsing group abbr-len)
   (let ((name (etypecase name-param
 		(string

Index: sb-aclrepl.asd
===================================================================
RCS file: /cvsroot/sbcl/sbcl/contrib/sb-aclrepl/sb-aclrepl.asd,v
retrieving revision 1.10
retrieving revision 1.11
diff -u -d -r1.10 -r1.11
--- sb-aclrepl.asd	27 Apr 2003 17:00:28 -0000	1.10
+++ sb-aclrepl.asd	12 May 2003 04:40:31 -0000	1.11
@@ -3,6 +3,9 @@
 (defpackage #:sb-aclrepl-system (:use #:asdf #:cl))
 (in-package #:sb-aclrepl-system)
 
+;; Work-around for optimization note from EQL specializer
+(declaim (optimize (sb-ext:inhibit-warnings 3)))
+
 (defsystem sb-aclrepl
     :author "Kevin Rosenberg <ke...@ro...>"
     :description "An AllegroCL compatible REPL"
@@ -22,3 +25,5 @@
 (defmethod perform ((o test-op) (c (eql (find-system :sb-aclrepl-tests))))
   (or (funcall (intern "DO-TESTS" (find-package "SB-RT")))
       (error "test-op failed")))
+
+(declaim (optimize (sb-ext:inhibit-warnings 0)))