From 4f0804233ba6521d65379d054237a5f5af2208a3 Mon Sep 17 00:00:00 2001
From: Chris Hanson <org/chris-hanson/cph>
Date: Sun, 13 May 2018 17:13:21 -0700
Subject: [PATCH] A bunch of changes to implement R7RS exit/emergency-exit.

* The EXIT procedure has been removed.
* The %EXIT procedure has been renamed to EXIT.
* The EMERGENCY-EXIT procedure has been added.
* The optional argument to the above has been generalized to meet R7RS
  requirements.
* The QUIT procedure has been renamed to SUSPEND to more accurately reflect what
  it does.
* The names %EXIT and QUIT are deprecated aliases for EXIT and SUSPEND.
---
 src/6001/edextra.scm       |   2 +-
 src/6001/make.scm          |   8 +--
 src/edwin/basic.scm        |  10 +--
 src/edwin/dos.scm          |   4 +-
 src/edwin/editor.scm       |   2 +-
 src/edwin/intmod.scm       |   8 +--
 src/edwin/unix.scm         |   4 +-
 src/runtime/console-io.scm |   4 +-
 src/runtime/gc.scm         |   2 +-
 src/runtime/global.scm     | 123 ++++++++++++++++---------------------
 src/runtime/interrupt.scm  |   6 +-
 src/runtime/load.scm       |   4 +-
 src/runtime/runtime.pkg    |  29 +++++----
 src/runtime/swank.scm      |   2 +-
 14 files changed, 94 insertions(+), 114 deletions(-)

diff --git a/src/6001/edextra.scm b/src/6001/edextra.scm
index f92766834..1015f1272 100644
--- a/src/6001/edextra.scm
+++ b/src/6001/edextra.scm
@@ -387,7 +387,7 @@ option the file from the problem set will not be installed.
 (set! default-homedir-pathname (lambda () student-work-directory))
 
 (set! editor-can-exit? #f)
-(set! scheme-can-quit? #f)
+(set! scheme-can-suspend? #f)
 (set! paranoid-exit? #t)
 
 (set-variable! enable-transcript-buffer #t)
diff --git a/src/6001/make.scm b/src/6001/make.scm
index fb7265e1b..7d83658d0 100644
--- a/src/6001/make.scm
+++ b/src/6001/make.scm
@@ -49,13 +49,9 @@ USA.
  (lambda (integer)
    integer
    (warn "EXIT has been disabled.")))
-(param:%exit-hook
- (lambda (integer)
-   integer
-   (warn "%EXIT has been disabled.")))
-(param:quit-hook
+(param:suspend-hook
  (lambda ()
-   (warn "QUIT has been disabled.")))
+   (warn "SUSPEND has been disabled.")))
 
 (let ((edwin-env (->environment '(EDWIN)))
       (student-env (->environment '(STUDENT))))
diff --git a/src/edwin/basic.scm b/src/edwin/basic.scm
index 50b14d24a..964796dd2 100644
--- a/src/edwin/basic.scm
+++ b/src/edwin/basic.scm
@@ -315,13 +315,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, or to prevent the editor from
+;; same effect as calling EXIT, or to prevent the editor from
 ;; returning to scheme.
 (define editor-can-exit? #t)
 
-;; Set this to #F to indicate that calling QUIT has the same effect
-;; as calling %EXIT, or to prevent the editor from suspending to the OS.
-(define scheme-can-quit?
+;; Set this to #F to indicate that calling SUSPEND has the same effect
+;; as calling EXIT, or to prevent the editor from suspending to the OS.
+(define scheme-can-suspend?
   #t)
 
 ;; Set this to #T to force the exit commands to always prompt for
@@ -334,7 +334,7 @@ With argument, saves visited file first."
   "P"
   (lambda (argument)
     (if argument (save-buffer (current-buffer) #f))
-    (if (and scheme-can-quit? (os/scheme-can-quit?))
+    (if (and scheme-can-suspend? (os/scheme-can-suspend?))
 	(quit-scheme)
 	(editor-error "Scheme cannot be suspended"))))
 
diff --git a/src/edwin/dos.scm b/src/edwin/dos.scm
index 67952bcc3..b2e978af4 100644
--- a/src/edwin/dos.scm
+++ b/src/edwin/dos.scm
@@ -35,11 +35,11 @@ USA.
 (define (os/restore-modes-to-updated-file! pathname modes)
   (set-file-modes! pathname (fix:or modes nt-file-mode/archive)))
 
-(define (os/scheme-can-quit?)
+(define (os/scheme-can-suspend?)
   #t)
 
 (define (os/quit dir)
-  (with-real-working-directory-pathname dir %quit))
+  (with-real-working-directory-pathname dir suspend))
 
 (define (with-real-working-directory-pathname dir thunk)
   (let ((inside (->namestring (directory-pathname-as-file dir)))
diff --git a/src/edwin/editor.scm b/src/edwin/editor.scm
index 9c7e9e83e..424daa1fe 100644
--- a/src/edwin/editor.scm
+++ b/src/edwin/editor.scm
@@ -495,7 +495,7 @@ TRANSCRIPT    messages appear in transcript buffer, if it is enabled;
   (within-continuation editor-abort reset-editor))
 
 (define (exit-scheme)
-  (within-continuation editor-abort %exit))
+  (within-continuation editor-abort exit))
 
 (define (editor-grab-display editor receiver)
   (display-type/with-display-grabbed (editor-display-type editor)
diff --git a/src/edwin/intmod.scm b/src/edwin/intmod.scm
index 2a8d5623e..600e8f6f4 100644
--- a/src/edwin/intmod.scm
+++ b/src/edwin/intmod.scm
@@ -122,8 +122,8 @@ evaluated in the specified inferior REPL buffer."
 				    (detach-thread thread)
 				    thread))))
 	(attach-buffer-interface-port! buffer port)
-	(parameterize* (list (cons param:%exit-hook inferior-repl/%exit)
-			     (cons param:quit-hook inferior-repl/quit))
+	(parameterize* (list (cons param:exit-hook inferior-repl/exit)
+			     (cons param:suspend-hook inferior-repl/suspend))
 	  (lambda ()
 	    (dynamic-wind
 	     (lambda () unspecific)
@@ -151,10 +151,10 @@ evaluated in the specified inferior REPL buffer."
      (set-working-directory-pathname!
       (buffer-default-directory (port/buffer port))))))
 
-(define (inferior-repl/%exit #!optional integer)
+(define (inferior-repl/exit #!optional integer)
   (exit-current-thread (if (default-object? integer) 0 integer)))
 
-(define (inferior-repl/quit)
+(define (inferior-repl/suspend)
   unspecific)
 
 (define (current-repl-buffer #!optional buffer)
diff --git a/src/edwin/unix.scm b/src/edwin/unix.scm
index f48c5d5e5..65996c018 100644
--- a/src/edwin/unix.scm
+++ b/src/edwin/unix.scm
@@ -643,12 +643,12 @@ option, instead taking -P <filename>."
 
 ;;;; Miscellaneous
 
-(define (os/scheme-can-quit?)
+(define (os/scheme-can-suspend?)
   (subprocess-job-control-available?))
 
 (define (os/quit dir)
   dir					; ignored
-  (%quit))
+  (suspend))
 
 (define (os/set-file-modes-writeable! pathname)
   (set-file-modes! pathname #o777))
diff --git a/src/runtime/console-io.scm b/src/runtime/console-io.scm
index 587209934..c722b0a85 100644
--- a/src/runtime/console-io.scm
+++ b/src/runtime/console-io.scm
@@ -121,8 +121,8 @@ USA.
 	  (if (let ((condition (nearest-repl/condition)))
 		(and condition
 		     (condition/error? condition)))
-	      (%exit 1)
-	      (%exit))))
+	      (exit 'eof)
+	      (exit))))
     char))
 
 (define (operation/read-finish port)
diff --git a/src/runtime/gc.scm b/src/runtime/gc.scm
index 37fab3f8a..68d6a02a0 100644
--- a/src/runtime/gc.scm
+++ b/src/runtime/gc.scm
@@ -137,7 +137,7 @@ USA.
 	 (if (nearest-cmdl/batch-mode?)
 	     (lambda (port)
 	       (newline port)
-	       (%exit 1))
+	       (exit 'gc-out-of-space))
 	     (lambda (port)
 	       port
 	       (with-gc-notification! #t gc-clean))))))))
diff --git a/src/runtime/global.scm b/src/runtime/global.scm
index c9a01cb51..79077ebaa 100644
--- a/src/runtime/global.scm
+++ b/src/runtime/global.scm
@@ -75,32 +75,19 @@ USA.
 (define (host-big-endian?)
   host-big-endian?-saved)
 
-(define host-big-endian?-saved)
-
-(define ephemeron-type)
-
-(define (initialize-package!)
-  ;; Assumptions:
-  ;; * Word length is 32 or 64 bits.
-  ;; * Type codes are at most 8 bits.
-  ;; * Zero is a non-pointer type code.
-  (set! host-big-endian?-saved
-	(case (object-datum
-	       (vector-ref
-		(object-new-type (ucode-type vector)
-				 "\000\001\002\000\000\003\004\000")
-		1))
-	  ((#x00010200 #x0001020000030400) #t)
-	  ((#x00020100 #x0004030000020100) #f)
-	  (else (error "Unable to determine endianness of host."))))
-  (add-secondary-gc-daemon! clean-obarray)
-  (set! param:exit-hook (make-settable-parameter default/exit))
-  (set! param:%exit-hook (make-settable-parameter default/%exit))
-  (set! param:quit-hook (make-settable-parameter default/quit))
-  ;; Kludge until the next released version, to avoid a bootstrapping
-  ;; failure.
-  (set! ephemeron-type (microcode-type 'ephemeron))
-  unspecific)
+;; Assumptions:
+;; * Word length is 32 or 64 bits.
+;; * Type codes are at most 8 bits.
+;; * Zero is a non-pointer type code.
+(define-deferred host-big-endian?-saved
+  (case (object-datum
+	 (vector-ref
+	  (object-new-type (ucode-type vector)
+			   "\000\001\002\000\000\003\004\000")
+	  1))
+    ((#x00010200 #x0001020000030400) #t)
+    ((#x00020100 #x0004030000020100) #f)
+    (else (error "Unable to determine endianness of host."))))
 
 ;;;; Potpourri
 
@@ -208,54 +195,48 @@ USA.
       (if (< (real-time-clock) end)
 	  (wait-loop)))))
 
-(define hook/exit #!default)
-(define hook/%exit #!default)
-(define hook/quit #!default)
-
-(define param:exit-hook)
-(define param:%exit-hook)
-(define param:quit-hook)
-
-(define (get-exit-hook)
-  (if (default-object? hook/exit)
-      (param:exit-hook)
-      hook/exit))
-
-(define (get-%exit-hook)
-  (if (default-object? hook/%exit)
-      (param:%exit-hook)
-      hook/%exit))
-
-(define (get-quit-hook)
-  (if (default-object? hook/quit)
-      (param:quit-hook)
-      hook/quit))
-
-(define (exit #!optional integer)
-  ((get-exit-hook) (if (default-object? integer) #f integer)))
+(define (exit #!optional object)
+  ((param:exit-hook) (exit-object->code object)))
 
-(define (default/exit integer)
-  (if (prompt-for-confirmation "Kill Scheme")
-      (%exit integer)))
+(define (default-exit code)
+  (event-distributor/invoke! event:before-exit)
+  (within-continuation root-continuation
+    (lambda ()
+      ((ucode-primitive exit-with-value 1) code))))
+
+(define-deferred param:exit-hook
+  (make-settable-parameter default-exit))
+
+(define (emergency-exit #!optional object)
+  ((ucode-primitive exit-with-value 1) (exit-object->code object)))
+
+(define (exit-object->code object)
+  (cond ((or (eq? #t object) (default-object? object))
+	 normal-termination-code)
+	((not object)
+	 abnormal-termination-code)
+	((and (exact-nonnegative-integer? object)
+	      (< object (microcode-termination/code-limit)))
+	 object)
+	((and (interned-symbol? object)
+	      (microcode-termination/name->code object)))
+	(else
+	 abnormal-termination-code)))
 
-(define (%exit #!optional integer)
-  ((get-%exit-hook) integer))
+(define-deferred normal-termination-code
+  (microcode-termination/name->code 'halt))
 
-(define (default/%exit #!optional integer)
-  (event-distributor/invoke! event:before-exit)
-  (if (or (default-object? integer)
-	  (not integer))
-      ((ucode-primitive exit 0))
-      ((ucode-primitive exit-with-value 1) integer)))
+(define-deferred abnormal-termination-code
+  (microcode-termination/name->code 'save-and-exit))
 
-(define (quit)
-  ((get-quit-hook)))
+(define (suspend)
+  ((param:suspend-hook)))
 
-(define (%quit)
-  (with-absolutely-no-interrupts (ucode-primitive halt))
-  unspecific)
+(define (default-suspend)
+  (with-absolutely-no-interrupts (ucode-primitive halt)))
 
-(define default/quit %quit)
+(define-deferred param:suspend-hook
+  (make-settable-parameter default-suspend))
 
 (define user-initial-environment
   (*make-environment system-global-environment
@@ -416,6 +397,10 @@ USA.
 		       (else (vector-set! obarray index tail))))
 	       (find-broken-entry (vector-ref obarray index) #f)
 	       (loop index))))))))
+
+(add-boot-init!
+ (lambda ()
+   (add-secondary-gc-daemon! clean-obarray)))
 
 (define (impurify object)
   object)
@@ -678,7 +663,7 @@ USA.
   ((ucode-primitive make-ephemeron 2) (canonicalize key) (canonicalize datum)))
 
 (define (ephemeron? object)
-  (object-type? ephemeron-type object))
+  (object-type? (ucode-type ephemeron) object))
 
 (define-guarantee ephemeron "ephemeron")
 
diff --git a/src/runtime/interrupt.scm b/src/runtime/interrupt.scm
index 052b780eb..a17229581 100644
--- a/src/runtime/interrupt.scm
+++ b/src/runtime/interrupt.scm
@@ -98,7 +98,7 @@ USA.
       (bind-condition-handler (list condition-type:serious-condition)
 	  (lambda (condition)
 	    condition
-	    (%exit))
+	    (exit))
 	(lambda ()
 	  (bind-condition-handler (list condition-type:warning)
 	      (lambda (condition)
@@ -108,8 +108,8 @@ USA.
 	      (if (not (disk-save (merge-pathnames "scheme_suspend"
 						   (user-homedir-pathname))
 				  true))
-		  (%exit))))))
-      (%exit)))
+		  (exit))))))
+      (exit)))
 
 (define (gc-out-of-space-handler . args)
   args
diff --git a/src/runtime/load.scm b/src/runtime/load.scm
index 53a1a2f2c..e33a90a7d 100644
--- a/src/runtime/load.scm
+++ b/src/runtime/load.scm
@@ -672,7 +672,7 @@ ADDITIONAL OPTIONS supported by this band:\n")
 	    (newline)
 	    (write-string description)
 	    (newline)))))
-  (%exit 0))
+  (exit))
 
 (define (initialize-command-line-parsers)
   (set! *command-line-parsers* '())
@@ -715,7 +715,7 @@ ADDITIONAL OPTIONS supported by this band:\n")
 			    repl)))))
     "Evaluates the argument expressions as if in the REPL.")
   (simple-command-line-parser "help" show-command-line-options #f)
-  (simple-command-line-parser "version" (lambda () (%exit 0)) #f)
+  (simple-command-line-parser "version" (lambda () (exit)) #f)
   (set-command-line-parser!
    "args" collect-args
    (command-line-option-description
diff --git a/src/runtime/runtime.pkg b/src/runtime/runtime.pkg
index 745096a52..164176b06 100644
--- a/src/runtime/runtime.pkg
+++ b/src/runtime/runtime.pkg
@@ -506,10 +506,10 @@ USA.
   (files "global")
   (parent (runtime))
   (export () deprecated:miscellaneous-global
+	  (%exit exit)
+	  (quit suspend)
 	  (with-values call-with-values))
   (export ()
-	  %exit
-	  %quit
 	  (*the-non-printing-object* unspecific)
 	  <hook-list>
 	  append-hook-to-list
@@ -520,8 +520,7 @@ USA.
 	  cell-contents
 	  cell?
 	  constant-procedure
-	  default/exit
-	  default/quit
+	  emergency-exit		;R7RS
 	  environment-link-name
 	  ephemeron-broken?
 	  ephemeron-datum
@@ -530,7 +529,7 @@ USA.
 	  eq?
 	  error-procedure
 	  eval
-	  exit
+	  exit				;R7RS
 	  false-procedure
 	  fasdump
 	  for-each-interned-symbol
@@ -538,9 +537,6 @@ USA.
 	  get-interrupt-enables
 	  hook-in-list?
 	  hook-list?
-	  hook/exit
-	  hook/%exit
-	  hook/quit
 	  hook/scode-eval
 	  host-big-endian?
 	  hunk3-cons
@@ -573,14 +569,13 @@ USA.
 	  object-type
 	  object-type?
 	  pa
-	  param:%exit-hook
 	  param:exit-hook
-	  param:quit-hook
+	  param:suspend-hook
 	  pointer-type-code?
 	  primitive-procedure-arity
 	  primitive-procedure-documentation
 	  pwd
-	  quit
+	  suspend
 	  (reference-barrier identity-procedure)
 	  remove-hook-from-list
 	  run-hooks-in-list
@@ -625,8 +620,7 @@ USA.
   (export (runtime)
 	  strip-angle-brackets)
   (import (runtime thread)
-	  with-obarray-lock)
-  (initialization (initialize-package!)))
+	  with-obarray-lock))
 
 (define-package (runtime merge-sort)
   (files "msort")
@@ -3253,6 +3247,9 @@ USA.
 	  microcode-system-call-error/code->name
 	  microcode-system-call-error/name->code
 	  microcode-system-call/code->name)
+  (export (runtime miscellaneous-global)
+	  microcode-termination/code-limit
+	  microcode-termination/name->code)
   (export (runtime save/restore)
 	  read-microcode-tables!)
   (initialization (initialize-package!)))
@@ -3929,11 +3926,13 @@ USA.
 	  standard-breakpoint-hook
 	  ve
 	  with-repl-eval-boundary)
+  (export (runtime debugger)
+	  write-restarts)
   (export (runtime emacs-interface)
 	  hook/error-decision
 	  set-cmdl/port!)
-  (export (runtime debugger)
-	  write-restarts)
+  (export (runtime miscellaneous-global)
+	  root-continuation)
   (export (runtime working-directory)
 	  cmdl/set-default-directory)
   (initialization (initialize-package!)))
diff --git a/src/runtime/swank.scm b/src/runtime/swank.scm
index eff60c528..ef69b465a 100644
--- a/src/runtime/swank.scm
+++ b/src/runtime/swank.scm
@@ -585,7 +585,7 @@ USA.
 
 (define (swank:quit-lisp socket)
   socket
-  (%exit))
+  (exit))
 
 ;;;; Some unimplemented stuff.
 
-- 
2.25.1