* 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.
(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)
(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))))
;;;; 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
"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"))))
(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)))
(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)
(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)
(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)
\f
(define (current-repl-buffer #!optional buffer)
\f
;;;; 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))
(if (let ((condition (nearest-repl/condition)))
(and condition
(condition/error? condition)))
- (%exit 1)
- (%exit))))
+ (exit 'eof)
+ (exit))))
char))
(define (operation/read-finish port)
(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))))))))
(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."))))
\f
;;;; Potpourri
(if (< (real-time-clock) end)
(wait-loop)))))
\f
-(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))
\f
(define user-initial-environment
(*make-environment system-global-environment
(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)))
\f
(define (impurify object)
object)
((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")
(bind-condition-handler (list condition-type:serious-condition)
(lambda (condition)
condition
- (%exit))
+ (exit))
(lambda ()
(bind-condition-handler (list condition-type:warning)
(lambda (condition)
(if (not (disk-save (merge-pathnames "scheme_suspend"
(user-homedir-pathname))
true))
- (%exit))))))
- (%exit)))
+ (exit))))))
+ (exit)))
(define (gc-out-of-space-handler . args)
args
(newline)
(write-string description)
(newline)))))
- (%exit 0))
+ (exit))
\f
(define (initialize-command-line-parsers)
(set! *command-line-parsers* '())
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
(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
cell-contents
cell?
constant-procedure
- default/exit
- default/quit
+ emergency-exit ;R7RS
environment-link-name
ephemeron-broken?
ephemeron-datum
eq?
error-procedure
eval
- exit
+ exit ;R7RS
false-procedure
fasdump
for-each-interned-symbol
get-interrupt-enables
hook-in-list?
hook-list?
- hook/exit
- hook/%exit
- hook/quit
hook/scode-eval
host-big-endian?
hunk3-cons
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
(export (runtime)
strip-angle-brackets)
(import (runtime thread)
- with-obarray-lock)
- (initialization (initialize-package!)))
+ with-obarray-lock))
(define-package (runtime merge-sort)
(files "msort")
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!)))
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!)))
(define (swank:quit-lisp socket)
socket
- (%exit))
+ (exit))
\f
;;;; Some unimplemented stuff.
projects / mit-scheme.git / commitdiff