mirror/guile
mirror/guile
1
Fork 0
mirror of https://git.savannah.gnu.org/git/guile.git synced 2025-05-20 11:40:18 +02:00
Code Activity

* boot-9.scm (error-catching-loop thunk): use a status variable to

Browse source 
return the quit args.
(scm-style-repl): call -quit, passing return value from
error-catching-repl.  Make -quit return its args.
stand-along-repl: comment out, since it seems unused.
(top-repl): convert the value returned by scm-style-repl to
an integer and return it.

(error-catching-loop thunk): discard trailing junk after a (quit).
This commit is contained in:
Gary Houston 1997-03-02 06:09:41 +00:00
parent e6aa2a8a24
commit 8e44e7a0c7
3 changed files with 100 additions and 69 deletions
Download patch file Download diff file Expand all files Collapse all files

12
ice-9/ChangeLog
View file

@ -1,3 +1,15 @@
Sun Mar 2 05:25:11 1997 Gary Houston <ghouston@actrix.gen.nz>
* boot-9.scm (error-catching-loop thunk): use a status variable to
return the quit args.
(scm-style-repl): call -quit, passing return value from
error-catching-repl. Make -quit return its args.
stand-along-repl: comment out, since it seems unused.
(top-repl): convert the value returned by scm-style-repl to
an integer and return it.
(error-catching-loop thunk): discard trailing junk after a (quit).
Sat Mar 1 15:24:39 1997 Mikael Djurfeldt <mdj@mdj.nada.kth.se>
* boot-9.scm: Removed the old printer code.

8
ice-9/Makefile.in
View file

@ -37,11 +37,11 @@ INSTALL_PROGRAM = @INSTALL_PROGRAM@
INSTALL_DATA = @INSTALL_DATA@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
transform = @program_transform_name@
VERSION = @VERSION@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
module = @module@
PACKAGE = @PACKAGE@
MAINT = @MAINT@
INSTALL_SCRIPT = @INSTALL_SCRIPT@
PACKAGE = @PACKAGE@
VERSION = @VERSION@
module = @module@
AUTOMAKE_OPTIONS = foreign

149
ice-9/boot-9.scm
View file

@ -2058,66 +2058,74 @@
(define abort-hook '())
(define (error-catching-loop thunk)
(define (loop first)
(let ((next
(catch #t
(let ((status #f))
(define (loop first)
(let ((next
(catch #t
(lambda ()
(lazy-catch #t
(lambda ()
(dynamic-wind
(lambda () (unmask-signals))
(lambda ()
(first)
;; This line is needed because mark doesn't do closures quite right.
;; Unreferenced locals should be collected.
;;
(set! first #f)
(let loop ((v (thunk)))
(loop (thunk)))
#f)
(lambda () (mask-signals))))
(lazy-catch #t
(lambda ()
(dynamic-wind
(lambda () (unmask-signals))
(lambda ()
(first)
;; This line is needed because mark
;; doesn't do closures quite right.
;; Unreferenced locals should be
;; collected.
;;
(set! first #f)
(let loop ((v (thunk)))
(loop (thunk)))
#f)
(lambda () (mask-signals))))
lazy-handler-dispatch))
(lambda (key . args)
(case key
((quit)
(force-output)
#f)
lazy-handler-dispatch))
(lambda (key . args)
(case key
((quit)
(read-line) ; discard trailing junk and linefeed.
(force-output)
(set! status args)
#f)
((switch-repl)
(apply throw 'switch-repl args))
((switch-repl)
(apply throw 'switch-repl args))
((abort)
;; This is one of the closures that require
;; (set! first #f) above
;;
(lambda ()
(run-hooks abort-hook)
(force-output)
(display "ABORT: " (current-error-port))
(write args (current-error-port))
(newline (current-error-port))
(if (and (not has-shown-debugger-hint?)
(not (memq 'backtrace (debug-options-interface)))
(stack? the-last-stack))
(begin
(newline (current-error-port))
(display "Type \"(backtrace)\" to get more information.\n" (current-error-port))
(set! has-shown-debugger-hint? #t)))
(set! stack-saved? #f)))
((abort)
;; This is one of the closures that require
;; (set! first #f) above
;;
(lambda ()
(run-hooks abort-hook)
(force-output)
(display "ABORT: " (current-error-port))
(write args (current-error-port))
(newline (current-error-port))
(if (and (not has-shown-debugger-hint?)
(not (memq 'backtrace
(debug-options-interface)))
(stack? the-last-stack))
(begin
(newline (current-error-port))
(display
"Type \"(backtrace)\" to get more information.\n"
(current-error-port))
(set! has-shown-debugger-hint? #t)))
(set! stack-saved? #f)))
(else
;; This is the other cons-leak closure...
(lambda ()
(cond ((= (length args) 4)
(apply handle-system-error key args))
(else
(apply bad-throw key args))))))))))
(and next (loop next))))
(loop (lambda () #t)))
(else
;; This is the other cons-leak closure...
(lambda ()
(cond ((= (length args) 4)
(apply handle-system-error key args))
(else
(apply bad-throw key args))))))))))
(if next (loop next) status)))
(loop (lambda () #t))))
;;(define the-last-stack #f) Defined by scm_init_backtrace ()
(define stack-saved? #f)
@ -2252,13 +2260,13 @@
(repl-report))
(force-output)))))
(-quit (lambda ()
(-quit (lambda (args)
(if scm-repl-verbose
(begin
(display ";;; QUIT executed, repl exitting")
(newline)
(repl-report)))
#t))
args))
(-abort (lambda ()
(if scm-repl-verbose
@ -2268,15 +2276,17 @@
(repl-report)))
(repl -read -eval -print))))
(error-catching-repl -read
-eval
-print)))
(let ((status (error-catching-repl -read
-eval
-print)))
(-quit status))))
(define (stand-alone-repl)
(let ((oport (current-input-port)))
(set-current-input-port *stdin*)
(scm-style-repl)
(set-current-input-port oport)))
;(define (stand-alone-repl)
; (let ((oport (current-input-port)))
; (set-current-input-port *stdin*)
; (scm-style-repl)
; (set-current-input-port oport)))
@ -2444,7 +2454,16 @@
;; (set-current-output-port outp)
;; (set-current-error-port errp)
(define (top-repl) (scm-style-repl))
(define (top-repl)
;; scm-style-repl returns the list of arguments from quit: convert to
;; an integer status and return.
(let ((quit-args (scm-style-repl)))
(if (null? quit-args)
0
(let ((cqa (car quit-args)))
(cond ((number? cqa) cqa)
((eq? cqa #f) 1)
(else 0))))))
(defmacro false-if-exception (expr)
`(catch #t (lambda () ,expr)