* boot-9.scm (error-catching-loop thunk): use a status variable to

return the quit args.
(scm-style-repl): call -quit, passing return value from
error-catching-repl.  Make -quit return its args.
stand-along-repl: comment out, since it seems unused.
(top-repl): convert the value returned by scm-style-repl to
an integer and return it.

(error-catching-loop thunk): discard trailing junk after a (quit).

ice-9/ChangeLog

@@ -1,3 +1,15 @@
+Sun Mar  2 05:25:11 1997  Gary Houston  <ghouston@actrix.gen.nz>
+
+	* boot-9.scm (error-catching-loop thunk): use a status variable to
+	return the quit args.
+	(scm-style-repl): call -quit, passing return value from
+	error-catching-repl.  Make -quit return its args.
+	stand-along-repl: comment out, since it seems unused.
+	(top-repl): convert the value returned by scm-style-repl to
+	an integer and return it.
+	
+	(error-catching-loop thunk): discard trailing junk after a (quit).
+
 Sat Mar  1 15:24:39 1997  Mikael Djurfeldt  <mdj@mdj.nada.kth.se>
 
 	* boot-9.scm: Removed the old printer code.

ice-9/Makefile.in

@@ -37,11 +37,11 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@
 INSTALL_DATA = @INSTALL_DATA@
 INSTALL_SCRIPT = @INSTALL_SCRIPT@
 transform = @program_transform_name@
-VERSION = @VERSION@
-INSTALL_SCRIPT = @INSTALL_SCRIPT@
-module = @module@
-PACKAGE = @PACKAGE@
 MAINT = @MAINT@
+INSTALL_SCRIPT = @INSTALL_SCRIPT@
+PACKAGE = @PACKAGE@
+VERSION = @VERSION@
+module = @module@
 
 AUTOMAKE_OPTIONS = foreign
 

ice-9/boot-9.scm

@@ -2058,66 +2058,74 @@
 (define abort-hook '())
 
 (define (error-catching-loop thunk)
-  (define (loop first)
+  (let ((status #f))
-    (let ((next 
+    (define (loop first)
-	   (catch #t
+      (let ((next 
+	     (catch #t
 
-	     (lambda ()
-	       (lazy-catch #t
-                 (lambda ()
-		   (dynamic-wind
-		    (lambda () (unmask-signals))
 		    (lambda ()
-		      (first)
+		      (lazy-catch #t
+				  (lambda ()
+				    (dynamic-wind
+				     (lambda () (unmask-signals))
+				     (lambda ()
+				       (first)
 				       
-		      ;; This line is needed because mark doesn't do closures quite right.
+				       ;; This line is needed because mark
-		      ;; Unreferenced locals should be collected.
+				       ;; doesn't do closures quite right.
-		      ;;
+				       ;; Unreferenced locals should be
-		      (set! first #f)
+				       ;; collected.
-		      (let loop ((v (thunk)))
+				       ;;
-			(loop (thunk)))
+				       (set! first #f)
-		      #f)
+				       (let loop ((v (thunk)))
-		    (lambda () (mask-signals))))
+					 (loop (thunk)))
+				       #f)
+				     (lambda () (mask-signals))))
 
-		 lazy-handler-dispatch))
+				  lazy-handler-dispatch))
 		    
-	     (lambda (key . args)
+		    (lambda (key . args)
-	       (case key
+		      (case key
-		 ((quit)
+			((quit)
-		  (force-output)
+			 (read-line)	; discard trailing junk and linefeed.
-		  #f)
+			 (force-output)
+			 (set! status args)
+			 #f)
 
-		 ((switch-repl)
+			((switch-repl)
-		  (apply throw 'switch-repl args))
+			 (apply throw 'switch-repl args))
 
-		 ((abort)
+			((abort)
-		  ;; This is one of the closures that require
+			 ;; This is one of the closures that require
-		  ;; (set! first #f) above
+			 ;; (set! first #f) above
-		  ;;
+			 ;;
-		  (lambda ()
+			 (lambda ()
-		    (run-hooks abort-hook)
+			   (run-hooks abort-hook)
-		    (force-output)
+			   (force-output)
-		    (display "ABORT: "  (current-error-port))
+			   (display "ABORT: "  (current-error-port))
-		    (write args (current-error-port))
+			   (write args (current-error-port))
-		    (newline (current-error-port))
+			   (newline (current-error-port))
-		    (if (and (not has-shown-debugger-hint?)
+			   (if (and (not has-shown-debugger-hint?)
-			     (not (memq 'backtrace (debug-options-interface)))
+				    (not (memq 'backtrace
-			     (stack? the-last-stack))
+					       (debug-options-interface)))
-			(begin
+				    (stack? the-last-stack))
-			  (newline (current-error-port))
+			       (begin
-			  (display "Type \"(backtrace)\" to get more information.\n" (current-error-port))
+				 (newline (current-error-port))
-			  (set! has-shown-debugger-hint? #t)))
+				 (display
-		    (set! stack-saved? #f)))
+				  "Type \"(backtrace)\" to get more information.\n"
+				  (current-error-port))
+				 (set! has-shown-debugger-hint? #t)))
+			   (set! stack-saved? #f)))
 
-		 (else
+			(else
-		  ;; This is the other cons-leak closure...
+			 ;; This is the other cons-leak closure...
-		  (lambda ()
+			 (lambda ()
-		    (cond ((= (length args) 4)
+			   (cond ((= (length args) 4)
-			   (apply handle-system-error key args))
+				  (apply handle-system-error key args))
-			  (else
+				 (else
-			   (apply bad-throw key args))))))))))
+				  (apply bad-throw key args))))))))))
-      (and next (loop next))))
+	(if next (loop next) status)))
-  (loop (lambda () #t)))
+    (loop (lambda () #t))))
 
 ;;(define the-last-stack #f) Defined by scm_init_backtrace ()
 (define stack-saved? #f)
@@ -2252,13 +2260,13 @@
 			       (repl-report))
 			   (force-output)))))
 
-	   (-quit (lambda ()
+	   (-quit (lambda (args)
 		    (if scm-repl-verbose
 			(begin
 			  (display ";;; QUIT executed, repl exitting")
 			  (newline)
 			  (repl-report)))
-		    #t))
+		    args))
 
 	   (-abort (lambda ()
 		     (if scm-repl-verbose
@@ -2268,15 +2276,17 @@
 			   (repl-report)))
 		     (repl -read -eval -print))))
 
-    (error-catching-repl -read
+    (let ((status (error-catching-repl -read
-			 -eval
+				       -eval
-			 -print)))
+				       -print)))
+      (-quit status))))
   
-(define (stand-alone-repl)
+
-  (let ((oport (current-input-port)))
+;(define (stand-alone-repl)
-    (set-current-input-port *stdin*)
+;  (let ((oport (current-input-port)))
-    (scm-style-repl)
+;    (set-current-input-port *stdin*)
-    (set-current-input-port oport)))
+;    (scm-style-repl)
+;    (set-current-input-port oport)))
 
 
 
@@ -2444,7 +2454,16 @@
 ;; (set-current-output-port outp)
 ;; (set-current-error-port errp)
 
-(define (top-repl) (scm-style-repl))
+(define (top-repl) 
+  ;; scm-style-repl returns the list of arguments from quit: convert to
+  ;; an integer status and return.
+  (let ((quit-args (scm-style-repl)))
+    (if (null? quit-args)
+	0
+	(let ((cqa (car quit-args)))
+	  (cond ((number? cqa) cqa)
+		((eq? cqa #f) 1)
+		(else 0))))))
 
 (defmacro false-if-exception (expr)
   `(catch #t (lambda () ,expr)