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

diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm
index f5f80f8ed44965a778ed11f4b590de75f407fca9..8c90e6e6fa0e758ee8242f31d17a449edd7bde36 100644 (file)
--- 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 d9117307878bb751d5e6618777fcf720702de141..e6a0c21492ea03a93219b6fa0891be5ea96f7096 100644 (file)
--- 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))))
+\f
+(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 d253fd9d343163db09aa44e70ce138a3f611d5c5..59ce68108e986ab7c788a41565de9c2bb625a286 100644 (file)
--- 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 e57d2111b90d489c862a08882cc36bb3122ce95c..9164344756c0c784586fb3c5e53fc00020cfec94 100644 (file)
--- 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))))
+\f
+(define (os/scheme-can-quit?)
+  (subprocess-job-control-available?))
+
+(define os/quit %quit)
\ No newline at end of file