~ chicken-core (chicken-5) 4e8ef70c5edeb6d4d0d81923842a57300bab253c
commit 4e8ef70c5edeb6d4d0d81923842a57300bab253c
Author: felix <felix@call-with-current-continuation.org>
AuthorDate: Mon Jul 18 00:28:41 2011 +0200
Commit: felix <felix@call-with-current-continuation.org>
CommitDate: Mon Jul 18 00:28:41 2011 +0200
added quit, q csi command invokes quit
diff --git a/csi.scm b/csi.scm
index bdaa518a..06708607 100644
--- a/csi.scm
+++ b/csi.scm
@@ -130,7 +130,7 @@ EOF
(define (print-banner)
(newline)
- ;;UNUSED
+ ;;UNUSED BECAUSE IT IS STUPID
#;(when (and (tty-input?) (##sys#fudge 11))
(let* ((t (string-copy +product+))
(len (string-length t))
@@ -336,7 +336,7 @@ EOF
[xn (eval n)] )
(dump xe xn) ) )
((r) (report))
- ((q) (exit))
+ ((q) (##sys#quit-hook))
((l)
(let ((fns (string-split (read-line))))
(for-each load fns)
@@ -1087,7 +1087,10 @@ EOF
(do ([args args (cdr args)])
((null? args)
(unless batch
- (repl csi-eval)
+ (call/cc
+ (lambda (k)
+ (set! ##sys#quit-hook (lambda _ (k #f)))
+ (repl csi-eval)))
(##sys#write-char-0 #\newline ##sys#standard-output) ) )
(let* ((arg (car args)))
(cond ((member arg simple-options))
diff --git a/eval.scm b/eval.scm
index e2701566..af7dbd2a 100644
--- a/eval.scm
+++ b/eval.scm
@@ -1552,6 +1552,7 @@
(ehandler (##sys#error-handler))
(rhandler (##sys#reset-handler))
(lv #f)
+ (qh ##sys#quit-hook)
(uie ##sys#unbound-in-eval) )
(define (saveports)
@@ -1564,82 +1565,86 @@
(set! ##sys#standard-output stdout)
(set! ##sys#standard-error stderr) )
- (##sys#dynamic-wind
- (lambda ()
- (set! lv (load-verbose))
- (load-verbose #t)
- (##sys#error-handler
- (lambda (msg . args)
- (resetports)
- (##sys#print "\nError" #f ##sys#standard-error)
- (when msg
- (##sys#print ": " #f ##sys#standard-error)
- (##sys#print msg #f ##sys#standard-error) )
- (if (and (pair? args) (null? (cdr args)))
- (begin
- (##sys#print ": " #f ##sys#standard-error)
- (write-err args) )
- (begin
- (##sys#write-char-0 #\newline ##sys#standard-error)
- (write-err args) ) )
- (set! ##sys#repl-recent-call-chain
- (or (and-let* ((lexn ##sys#last-exception) ;XXX not really right
- ((##sys#structure? lexn 'condition))
- (a (member '(exn . call-chain) (##sys#slot lexn 2))))
- (let ((ct (cadr a)))
- (##sys#really-print-call-chain
- ##sys#standard-error ct
- "\n\tCall history:\n")
- ct))
- (print-call-chain ##sys#standard-error)))
- (flush-output ##sys#standard-error) ) ) )
- (lambda ()
- (let loop ()
- (saveports)
- (call-with-current-continuation
- (lambda (c)
- (##sys#reset-handler
- (lambda ()
- (set! ##sys#read-error-with-line-number #f)
- (set! ##sys#enable-qualifiers #t)
- (resetports)
- (c #f) ) ) ) )
- (##sys#read-prompt-hook)
- (let ([exp ((or ##sys#repl-read-hook read))])
- (unless (eof-object? exp)
- (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
- (##sys#read-char-0 ##sys#standard-input) )
- (##sys#clear-trace-buffer)
- (set! ##sys#unbound-in-eval '())
- (receive result (evaluator exp)
- (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
- (let loop ((vars ##sys#unbound-in-eval) (u '()))
- (cond ((null? vars)
- (when (pair? u)
- (##sys#notice
- "the following toplevel variables are referenced but unbound:\n")
- (for-each
- (lambda (v)
- (##sys#print " " #f ##sys#standard-error)
- (##sys#print (car v) #t ##sys#standard-error)
- (when (cdr v)
- (##sys#print " (in " #f ##sys#standard-error)
- (##sys#print (cdr v) #t ##sys#standard-error)
- (##sys#write-char-0 #\) ##sys#standard-error) )
- (##sys#write-char-0 #\newline ##sys#standard-error) )
- u)
- (##sys#flush-output ##sys#standard-error)))
- ((or (memq (caar vars) u)
- (##sys#symbol-has-toplevel-binding? (caar vars)) )
- (loop (cdr vars) u) )
- (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
- (write-results result)
- (loop) ) ) ) ) )
- (lambda ()
- (load-verbose lv)
- (set! ##sys#unbound-in-eval uie)
- (##sys#error-handler ehandler)
- (##sys#reset-handler rhandler) ) ) ) ) ) )
+ (call-with-current-continuation
+ (lambda (k)
+ (##sys#dynamic-wind
+ (lambda ()
+ (set! lv (load-verbose))
+ (set! ##sys#quit-hook (lambda (result) (k result)))
+ (load-verbose #t)
+ (##sys#error-handler
+ (lambda (msg . args)
+ (resetports)
+ (##sys#print "\nError" #f ##sys#standard-error)
+ (when msg
+ (##sys#print ": " #f ##sys#standard-error)
+ (##sys#print msg #f ##sys#standard-error) )
+ (if (and (pair? args) (null? (cdr args)))
+ (begin
+ (##sys#print ": " #f ##sys#standard-error)
+ (write-err args) )
+ (begin
+ (##sys#write-char-0 #\newline ##sys#standard-error)
+ (write-err args) ) )
+ (set! ##sys#repl-recent-call-chain
+ (or (and-let* ((lexn ##sys#last-exception) ;XXX not really right
+ ((##sys#structure? lexn 'condition))
+ (a (member '(exn . call-chain) (##sys#slot lexn 2))))
+ (let ((ct (cadr a)))
+ (##sys#really-print-call-chain
+ ##sys#standard-error ct
+ "\n\tCall history:\n")
+ ct))
+ (print-call-chain ##sys#standard-error)))
+ (flush-output ##sys#standard-error) ) ) )
+ (lambda ()
+ (let loop ()
+ (saveports)
+ (call-with-current-continuation
+ (lambda (c)
+ (##sys#reset-handler
+ (lambda ()
+ (set! ##sys#read-error-with-line-number #f)
+ (set! ##sys#enable-qualifiers #t)
+ (resetports)
+ (c #f) ) ) ) )
+ (##sys#read-prompt-hook)
+ (let ([exp ((or ##sys#repl-read-hook read))])
+ (unless (eof-object? exp)
+ (when (char=? #\newline (##sys#peek-char-0 ##sys#standard-input))
+ (##sys#read-char-0 ##sys#standard-input) )
+ (##sys#clear-trace-buffer)
+ (set! ##sys#unbound-in-eval '())
+ (receive result (evaluator exp)
+ (when (and ##sys#warnings-enabled (pair? ##sys#unbound-in-eval))
+ (let loop ((vars ##sys#unbound-in-eval) (u '()))
+ (cond ((null? vars)
+ (when (pair? u)
+ (##sys#notice
+ "the following toplevel variables are referenced but unbound:\n")
+ (for-each
+ (lambda (v)
+ (##sys#print " " #f ##sys#standard-error)
+ (##sys#print (car v) #t ##sys#standard-error)
+ (when (cdr v)
+ (##sys#print " (in " #f ##sys#standard-error)
+ (##sys#print (cdr v) #t ##sys#standard-error)
+ (##sys#write-char-0 #\) ##sys#standard-error) )
+ (##sys#write-char-0 #\newline ##sys#standard-error) )
+ u)
+ (##sys#flush-output ##sys#standard-error)))
+ ((or (memq (caar vars) u)
+ (##sys#symbol-has-toplevel-binding? (caar vars)) )
+ (loop (cdr vars) u) )
+ (else (loop (cdr vars) (cons (car vars) u))) ) 9 ) )
+ (write-results result)
+ (loop) ) ) ) ) )
+ (lambda ()
+ (load-verbose lv)
+ (set! ##sys#quit-hook qh)
+ (set! ##sys#unbound-in-eval uie)
+ (##sys#error-handler ehandler)
+ (##sys#reset-handler rhandler) ) ) ) ) ) ) ))
;;; SRFI-10:
diff --git a/library.scm b/library.scm
index f5590526..a5897f44 100644
--- a/library.scm
+++ b/library.scm
@@ -145,8 +145,10 @@ EOF
;;; System routines:
-(define (exit . code) (apply (##sys#exit-handler) code))
+(define (exit #!optional code) ((##sys#exit-handler) code))
(define (reset) ((##sys#reset-handler)))
+(define (##sys#quit-hook result) ((##sys#reset-handler)))
+(define (quit #!optional result) (##sys#quit-hook result))
(define (##sys#error . args)
(if (pair? args)
diff --git a/manual/Unit eval b/manual/Unit eval
index 69eaeca5..181d3688 100644
--- a/manual/Unit eval
+++ b/manual/Unit eval
@@ -110,6 +110,8 @@ any arguments to the value of {{(current-error-port)}} and reset.
If {{EVALUATOR}} is given, it should be a procedure of one argument that
is used in place of {{eval}} to evaluate each entered expression.
+You can use {{quit}} to terminate the current read-eval-print loop.
+
=== Loading extension libraries
diff --git a/manual/Unit library b/manual/Unit library
index d5856ee0..619b0eb2 100644
--- a/manual/Unit library
+++ b/manual/Unit library
@@ -420,6 +420,8 @@ Exit the running process and return exit-code, which defaults to 0
Note that pending {{dynamic-wind}} thunks are ''not'' invoked when exiting your program in this way.
+
+
==== build-platform
<procedure>(build-platform)</procedure>
@@ -676,6 +678,14 @@ Returns an s-expression with debug information for the procedure {{PROC}}, or
{{#f}}, if {{PROC}} has no associated debug information.
+==== quit
+
+<procedure>(quit [RESULT])</procedure>
+
+In the interpreter {{quit}} exits the currently active read-eval-print loop.
+In compiled code, it is equivalent to calling {{reset}}. See also: {{repl}}.
+
+
==== reset
<procedure>(reset)</procedure>
diff --git a/types.db b/types.db
index 7363afb0..1603fda7 100644
--- a/types.db
+++ b/types.db
@@ -392,6 +392,7 @@
(program-name (procedure program-name (#!optional string) string))
(promise? (procedure promise? (*) boolean))
(put! (procedure put! (symbol symbol *) undefined))
+(quit (procedure quit (#!optional *) noreturn))
(register-feature! (procedure register-feature! (#!rest symbol) undefined))
(remprop! (procedure remprop! (symbol symbol) undefined))
(rename-file (procedure rename-file (string string) string))
Trap