From: Guillermo J. Rozas <edu/mit/csail/zurich/gjr>
Date: Thu, 25 Feb 1993 02:43:42 +0000 (+0000)
Subject: Add os/quit and os/scheme-can-quit?
X-Git-Tag: 20090517-FFI~8465
X-Git-Url: https://birchwood-abbey.net/git?a=commitdiff_plain;h=d5c0d30f03dfcf1ecca4c46acf7621a7e923fc80;p=mit-scheme.git

Add os/quit and os/scheme-can-quit?
---

diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm
index f5f80f8ed..8c90e6e6f 100644
--- a/v7/src/edwin/basic.scm
+++ b/v7/src/edwin/basic.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: basic.scm,v 1.127 1993/02/02 04:34:53 gjr Exp $
+;;;	$Id: basic.scm,v 1.128 1993/02/25 02:43:26 gjr Exp $
 ;;;
 ;;;	Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
 ;;;
@@ -294,16 +294,13 @@ For a normal exit, you should use \\[exit-recursive-edit], NOT this command."
 ;;;; Leaving Edwin
 
 ;; Set this to #F to indicate that returning from the editor has the
-;; same effect as calling %EXIT.
+;; same effect as calling %EXIT, or to prevent the editor from
+;; returning to scheme.
 (define editor-can-exit? true)
 
 ;; Set this to #F to indicate that calling QUIT has the same effect
-;; as calling %EXIT.
+;; as calling %EXIT, or to prevent the editor from suspending to the OS.
 (define scheme-can-quit?
-  #|
-  (not (string=? microcode-id/operating-system-name "dos"))
-  |#
-  ;; DOS now has a pseudo-suspend
   true)
 
 ;; Set this to #T to force the exit commands to always prompt for
@@ -316,7 +313,7 @@ With argument, saves visited file first."
   "P"
   (lambda (argument)
     (if argument (save-buffer (current-buffer) false))
-    (if (not (and scheme-can-quit? (subprocess-job-control-available?)))
+    (if (and scheme-can-quit? (os/scheme-can-quit?))
 	(editor-error "Scheme cannot be suspended"))
     (quit-scheme)))
 
diff --git a/v7/src/edwin/dos.scm b/v7/src/edwin/dos.scm
index d91173078..e6a0c2149 100644
--- a/v7/src/edwin/dos.scm
+++ b/v7/src/edwin/dos.scm
@@ -1,6 +1,6 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: dos.scm,v 1.7 1993/02/02 04:38:46 gjr Exp $
+;;;	$Id: dos.scm,v 1.8 1993/02/25 02:42:56 gjr Exp $
 ;;;
 ;;;	Copyright (c) 1992-1993 Massachusetts Institute of Technology
 ;;;
@@ -455,4 +455,26 @@ Includes the new backup.  Must be > 0."
 		   (file-attributes/ls-time-string attr) 26 #\Space)
 		  name)))
       (insert-string entry point)
-      (insert-newline point))))
\ No newline at end of file
+      (insert-newline point))))
+
+(define (os/scheme-can-quit?)
+  true)
+
+(define (os/quit)
+  (without-interrupts
+    (lambda ()
+      (with-real-working-directory-pathname
+	(buffer-default-directory (current-buffer))
+	%quit))))
+
+(define (with-real-working-directory-pathname dir thunk)
+  (let ((inside dir)
+	(outside false))
+    (dynamic-wind
+     (lambda ()
+       (set! outside (working-directory-pathname))
+       (set-working-directory-pathname! inside))
+     thunk
+     (lambda ()
+       (set! inside (working-directory-pathname))
+       (set-working-directory-pathname! outside)))))
\ No newline at end of file
diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm
index d253fd9d3..59ce68108 100644
--- a/v7/src/edwin/editor.scm
+++ b/v7/src/edwin/editor.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: editor.scm,v 1.224 1992/09/14 23:12:23 cph Exp $
+;;;	$Id: editor.scm,v 1.225 1993/02/25 02:43:42 gjr Exp $
 ;;;
-;;;	Copyright (c) 1986, 1989-1992 Massachusetts Institute of Technology
+;;;	Copyright (c) 1986, 1989-1993 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -342,7 +342,7 @@ This does not affect editor errors or evaluation errors."
   (quit-editor-and (lambda () *the-non-printing-object*)))
 
 (define (quit-scheme)
-  (quit-editor-and (lambda () (%quit) (edit))))
+  (quit-editor-and (lambda () (os/quit) (edit))))
 
 (define (quit-editor-and thunk)
   (call-with-current-continuation
diff --git a/v7/src/edwin/unix.scm b/v7/src/edwin/unix.scm
index e57d2111b..916434475 100644
--- a/v7/src/edwin/unix.scm
+++ b/v7/src/edwin/unix.scm
@@ -1,8 +1,8 @@
 ;;; -*-Scheme-*-
 ;;;
-;;;	$Id: unix.scm,v 1.32 1993/02/21 05:55:02 cph Exp $
+;;;	$Id: unix.scm,v 1.33 1993/02/25 02:43:08 gjr Exp $
 ;;;
-;;;	Copyright (c) 1989-93 Massachusetts Institute of Technology
+;;;	Copyright (c) 1989-1993 Massachusetts Institute of Technology
 ;;;
 ;;;	This material was developed by the Scheme project at the
 ;;;	Massachusetts Institute of Technology, Department of
@@ -551,4 +551,9 @@ CANNOT contain the 'F' option."
       (insert-string
        (file-namestring
 	(extract-and-delete-string start (line-end start 0)))
-       start))))
\ No newline at end of file
+       start))))
+
+(define (os/scheme-can-quit?)
+  (subprocess-job-control-available?))
+
+(define os/quit %quit)
\ No newline at end of file