From 880539bb004330abc55616c8577845e397424701 Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 15 Feb 1991 18:17:14 +0000 Subject: [PATCH] Changes for new error system in runtime 14.106. --- v7/src/compiler/base/toplev.scm | 14 ++-- v7/src/compiler/etc/stackp.scm | 13 ++- v7/src/compiler/etc/xcbfdir.scm | 64 +++++++-------- .../compiler/machines/bobcat/make.scm-68040 | 4 +- v7/src/compiler/machines/mips/make.scm-big | 4 +- v7/src/compiler/machines/mips/make.scm-little | 4 +- v7/src/compiler/machines/spectrum/make.scm | 4 +- v7/src/edwin/artdebug.scm | 35 ++++---- v7/src/edwin/autold.scm | 7 +- v7/src/edwin/basic.scm | 32 +------- v7/src/edwin/bufwin.scm | 12 +-- v7/src/edwin/comman.scm | 6 +- v7/src/edwin/comred.scm | 8 +- v7/src/edwin/comwin.scm | 8 +- v7/src/edwin/editor.scm | 80 +++++++++++++------ v7/src/edwin/edwin.pkg | 11 +-- v7/src/edwin/evlcom.scm | 46 +++++------ v7/src/edwin/filcom.scm | 7 +- v7/src/edwin/fileio.scm | 65 +++++++-------- v7/src/edwin/info.scm | 11 ++- v7/src/edwin/iserch.scm | 9 +-- v7/src/edwin/make.scm | 4 +- v7/src/edwin/paths.scm | 6 +- v7/src/edwin/utils.scm | 8 +- v7/src/runtime/rgxcmp.scm | 25 ++++-- v8/src/compiler/etc/stackp.scm | 13 ++- v8/src/compiler/etc/xcbfdir.scm | 64 +++++++-------- 27 files changed, 291 insertions(+), 273 deletions(-) diff --git a/v7/src/compiler/base/toplev.scm b/v7/src/compiler/base/toplev.scm index 7a30750e4..aea45f1bd 100644 --- a/v7/src/compiler/base/toplev.scm +++ b/v7/src/compiler/base/toplev.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.30 1990/09/12 00:39:42 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/base/toplev.scm,v 4.31 1991/02/15 18:15:01 cph Exp $ -Copyright (c) 1988, 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1988-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -136,18 +136,16 @@ MIT in each case. |# (define (compiler:batch-compile input #!optional output) (fluid-let ((compiler:batch-mode? true)) - (bind-condition-handler '() compiler:batch-error-handler + (bind-condition-handler (list condition-type:error) + compiler:batch-error-handler (lambda () (if (default-object? output) (compile-bin-file input) (compile-bin-file input output)))))) (define (compiler:batch-error-handler condition) - (and (not (condition/internal? condition)) - (condition/error? condition) - (begin - (warn (condition/report-string condition)) - (compiler:abort false)))) + (warn (condition/report-string condition)) + (compiler:abort false)) (define (compiler:abort value) (if (not compiler:abort-handled?) diff --git a/v7/src/compiler/etc/stackp.scm b/v7/src/compiler/etc/stackp.scm index 82dd97660..643fe18ee 100644 --- a/v7/src/compiler/etc/stackp.scm +++ b/v7/src/compiler/etc/stackp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/stackp.scm,v 1.5 1988/12/31 06:41:50 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/stackp.scm,v 1.6 1991/02/15 18:14:31 cph Exp $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987-8, 1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,8 +41,7 @@ MIT in each case. |# (lambda () (write-continuation (if (default-object? continuation) - (or (error-continuation) - (current-proceed-continuation)) + (error-continuation) continuation))))) (if (or (default-object? filename) (not filename)) (do-it) @@ -54,6 +53,12 @@ MIT in each case. |# continuation) n)) +(define (error-continuation) + (let ((condition (nearest-repl/condition))) + (if (not condition) + (error "no error continuation")) + (condition/continuation condition))) + (define (write-continuation continuation) (let write-stack-stream ((stream (continuation->stream continuation)) (n 0)) diff --git a/v7/src/compiler/etc/xcbfdir.scm b/v7/src/compiler/etc/xcbfdir.scm index 3fc574c35..14a2d9b74 100644 --- a/v7/src/compiler/etc/xcbfdir.scm +++ b/v7/src/compiler/etc/xcbfdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/xcbfdir.scm,v 1.5 1991/02/06 02:53:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/etc/xcbfdir.scm,v 1.6 1991/02/15 18:14:48 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -43,36 +43,36 @@ MIT in each case. |# (two (pathname-new-type pathname "tch"))) (call-with-current-continuation (lambda (here) - (bind-condition-handler - '() - (lambda (condition) - (newline) - (display ";; *** Aborting ") - (display pathname) - (display " ***") - (newline) - (condition/write-report condition) - (newline) - (here 'next)) - (lambda () - (let ((touch-created-file?)) - (dynamic-wind - (lambda () - ;; file-touch returns #T if the file did not exist, - ;; it returns #F if it did. - (set! touch-created-file? - (file-touch two))) - (lambda () - (if (and touch-created-file? - (let ((one-time (file-modification-time one))) - (or (not one-time) - (< one-time - (file-modification-time pathname))))) - (processor pathname - (pathname-new-type pathname extension)))) - (lambda () - (if touch-created-file? - (delete-file two))))))))))) + (bind-condition-handler (list condition-type:error) + (lambda (condition) + (let ((port (current-output-port))) + (newline port) + (write-string ";; *** Aborting " port) + (display pathname port) + (write-string " ***" port) + (newline port) + (write-condition-report condition port) + (newline port)) + (here 'next)) + (lambda () + (let ((touch-created-file?)) + (dynamic-wind + (lambda () + ;; file-touch returns #T if the file did not exist, + ;; #F if it did. + (set! touch-created-file? (file-touch two)) + unspecific) + (lambda () + (if (and touch-created-file? + (let ((one-time (file-modification-time one))) + (or (not one-time) + (< one-time + (file-modification-time pathname))))) + (processor pathname + (pathname-new-type pathname extension)))) + (lambda () + (if touch-created-file? + (delete-file two))))))))))) (directory-read (merge-pathnames (pathname-as-directory (->pathname directory)) (->pathname "*.bin"))))) diff --git a/v7/src/compiler/machines/bobcat/make.scm-68040 b/v7/src/compiler/machines/bobcat/make.scm-68040 index 374f9c421..9dec1d1b1 100644 --- a/v7/src/compiler/machines/bobcat/make.scm-68040 +++ b/v7/src/compiler/machines/bobcat/make.scm-68040 @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.78 1991/02/15 00:19:58 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/bobcat/make.scm-68040,v 4.79 1991/02/15 18:15:32 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -41,4 +41,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (Motorola MC68020)" 4 78 '())) \ No newline at end of file +(add-system! (make-system "Liar (Motorola MC68020)" 4 79 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/make.scm-big b/v7/src/compiler/machines/mips/make.scm-big index 1db73d970..d90a8520e 100644 --- a/v7/src/compiler/machines/mips/make.scm-big +++ b/v7/src/compiler/machines/mips/make.scm-big @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.75 1991/02/15 00:19:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-big,v 4.79 1991/02/15 18:16:32 cph Exp $ $MC68020-Header: make.scm,v 4.73 90/05/03 15:17:24 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -42,4 +42,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (MIPS)" 4 78 '())) \ No newline at end of file +(add-system! (make-system "Liar (MIPS)" 4 79 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/mips/make.scm-little b/v7/src/compiler/machines/mips/make.scm-little index c0ddad3c9..6a0347f67 100644 --- a/v7/src/compiler/machines/mips/make.scm-little +++ b/v7/src/compiler/machines/mips/make.scm-little @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.75 1991/02/15 00:19:40 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/mips/make.scm-little,v 4.79 1991/02/15 18:16:32 cph Exp $ $MC68020-Header: make.scm,v 4.73 90/05/03 15:17:24 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -42,4 +42,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (MIPS)" 4 78 '())) \ No newline at end of file +(add-system! (make-system "Liar (MIPS)" 4 79 '())) \ No newline at end of file diff --git a/v7/src/compiler/machines/spectrum/make.scm b/v7/src/compiler/machines/spectrum/make.scm index 3fde391af..4727d42ef 100644 --- a/v7/src/compiler/machines/spectrum/make.scm +++ b/v7/src/compiler/machines/spectrum/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 4.77 1991/02/15 00:19:27 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/compiler/machines/spectrum/make.scm,v 4.79 1991/02/15 18:17:14 cph Exp $ $MC68020-Header: make.scm,v 4.76 90/08/21 02:20:43 GMT jinx Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -42,4 +42,4 @@ MIT in each case. |# ((package/reference (find-package name) 'INITIALIZE-PACKAGE!))) '((COMPILER MACROS) (COMPILER DECLARATIONS))) -(add-system! (make-system "Liar (HP PA)" 4 78 '())) \ No newline at end of file +(add-system! (make-system "Liar (HP PA)" 4 79 '())) \ No newline at end of file diff --git a/v7/src/edwin/artdebug.scm b/v7/src/edwin/artdebug.scm index 547498a5d..440c0b15b 100644 --- a/v7/src/edwin/artdebug.scm +++ b/v7/src/edwin/artdebug.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.3 1990/09/12 07:53:39 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/artdebug.scm,v 1.4 1991/02/15 18:13:01 cph Exp $ ;;; -;;; Copyright (c) 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -52,9 +52,7 @@ (if in-debugger? (exit-editor-and-signal-error condition) (fluid-let ((in-debugger? true)) - (let* ((continuation (condition/continuation condition)) - (buffer (continuation-browser continuation))) - (buffer-put! buffer 'DEBUG-CONDITION condition) + (let ((buffer (continuation-browser condition))) (select-buffer buffer) (standard-output buffer (lambda () @@ -67,8 +65,7 @@ Type \\[describe-mode] for more information. The error that started the debugger is: ")) - ((condition/reporter condition) condition - (current-output-port)))))))) + (write-condition-report condition (current-output-port)))))))) (define-command browse-continuation "Invoke the continuation-browser on CONTINUATION." @@ -79,11 +76,10 @@ The error that started the debugger is: (invoke-debugger-command command/print-subproblem-or-reduction buffer) (select-buffer buffer)))) -(define (continuation-browser continuation) +(define (continuation-browser object) (let ((buffer (new-buffer "*debug*"))) (set-buffer-major-mode! buffer (ref-mode-object continuation-browser)) - (buffer-put! buffer 'DEBUG-CONTINUATION continuation) - (buffer-put! buffer 'DEBUG-STATE (make-initial-dstate continuation)) + (buffer-put! buffer 'DEBUG-STATE (make-initial-dstate object)) (with-selected-buffer buffer (lambda () (setup-buffer-environment! buffer))) @@ -230,14 +226,15 @@ Prompts for a value to give the continuation as an argument." (lambda () (kill-buffer-interactive (current-buffer)))) -(define-command continuation-browser-error-info - "Show the error message associated with this continuation." +(define-command continuation-browser-condition-report + "Show the error message that started the continuation browser, if any." () - (lambda () - (let ((buffer (current-buffer))) - (with-debugger-hooks buffer - (lambda () - (show-error-info (buffer-get buffer 'DEBUG-CONDITION))))))) + (debugger-command-invocation command/condition-report)) + +(define-command continuation-browser-condition-restart + "Continue the program using a standard restart option." + () + (debugger-command-invocation command/condition-restart)) (define-major-mode continuation-browser fundamental "Debug" "You are in the Scheme debugger, where you can do the following: @@ -249,7 +246,7 @@ Prompts for a value to give the continuation as an argument." \\[continuation-browser-later-reduction] moves Forward to the previous reduction (later in time). \\[continuation-browser-goto] Goes to an arbitrary subproblem. \\[continuation-browser-summarize-subproblems] prints a summary (History) of all subproblems. -\\[continuation-browser-error-info] prints the error message Info. +\\[continuation-browser-condition-report] prints the error message Info. \\[continuation-browser-print-expression] pretty prints the current expression. \\[continuation-browser-print-environment-procedure] pretty prints the procedure that created the current environment. \\[continuation-browser-move-to-parent-environment] moves to the environment that is the Parent of the current environment. @@ -270,7 +267,7 @@ Prompts for a value to give the continuation as an argument." (define-key 'continuation-browser #\g 'continuation-browser-goto) (define-key 'continuation-browser #\h 'continuation-browser-summarize-subproblems) -(define-key 'continuation-browser #\i 'continuation-browser-error-info) +(define-key 'continuation-browser #\i 'continuation-browser-condition-report) (define-key 'continuation-browser #\l 'continuation-browser-print-expression) (define-key 'continuation-browser #\o 'continuation-browser-print-environment-procedure) diff --git a/v7/src/edwin/autold.scm b/v7/src/edwin/autold.scm index 15c7cdc0f..d2e21c68b 100644 --- a/v7/src/edwin/autold.scm +++ b/v7/src/edwin/autold.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.48 1990/09/07 18:39:34 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/autold.scm,v 1.49 1991/02/15 18:12:16 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -235,7 +235,8 @@ Second arg PURIFY? means purify the file's contents after loading; (define (load-edwin-file filename environment purify?) (with-output-to-transcript-buffer (lambda () - (bind-condition-handler '() evaluation-error-handler + (bind-condition-handler (list condition-type:error) + evaluation-error-handler (lambda () (fluid-let ((load/suppress-loading-message? true)) (load filename environment edwin-syntax-table purify?))))))) \ No newline at end of file diff --git a/v7/src/edwin/basic.scm b/v7/src/edwin/basic.scm index 0b6a7c06a..c174fd3d2 100644 --- a/v7/src/edwin/basic.scm +++ b/v7/src/edwin/basic.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.105 1990/10/03 04:53:58 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/basic.scm,v 1.106 1991/02/15 18:12:24 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -214,34 +214,6 @@ procedure when it fails to find a command." (define (barf-if-read-only) (editor-error "Trying to modify read only text.")) -(define-variable debug-on-editor-error - "True means signal Scheme error when an editor error occurs." - false) - -(define condition-type:editor-error - (make-error-type '() - (lambda (condition port) - (write-string "Editor error: " port) - (write-string (message-args->string (condition/irritants condition)) - port)))) - -(define (editor-error . strings) - (if (ref-variable debug-on-editor-error) - (call-with-current-continuation - (lambda (continuation) - (debug-scheme-error - (make-condition condition-type:editor-error - strings - continuation)) - (%editor-error))) - (begin - (if (not (null? strings)) (apply temporary-message strings)) - (%editor-error)))) - -(define (%editor-error) - (editor-beep) - (abort-current-command)) - (define (editor-failure . strings) (cond ((not (null? strings)) (apply temporary-message strings)) (*defining-keyboard-macro?* (clear-message))) diff --git a/v7/src/edwin/bufwin.scm b/v7/src/edwin/bufwin.scm index d039ca2a2..21b271cec 100644 --- a/v7/src/edwin/bufwin.scm +++ b/v7/src/edwin/bufwin.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.286 1990/11/02 03:22:50 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/bufwin.scm,v 1.287 1991/02/15 18:12:31 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -451,10 +451,10 @@ (define (clip-mark-to-display window mark) (if (not (mark? mark)) - (error:illegal-datum mark 'CLIP-MARK-TO-DISPLAY)) + (error:wrong-type-argument mark "mark" 'CLIP-MARK-TO-DISPLAY)) (if (and (%window-point window) (not (mark~ (%window-point window) mark))) - (error:datum-out-of-range mark 'CLIP-MARK-TO-DISPLAY)) + (error:bad-range-argument mark 'CLIP-MARK-TO-DISPLAY)) (cond ((group-display-start-index? (mark-group mark) (mark-index mark)) (group-display-start (mark-group mark))) ((group-display-end-index? (mark-group mark) (mark-index mark)) @@ -664,7 +664,7 @@ (if (%window-debug-trace window) ((%window-debug-trace window) 'window window 'set-buffer! new-buffer)) (if (not (buffer? new-buffer)) - (error:illegal-datum new-buffer 'set-window-buffer!)) + (error:wrong-type-argument new-buffer "buffer" 'SET-WINDOW-BUFFER!)) (if (%window-buffer window) (%unset-window-buffer! window)) (%set-window-buffer! window new-buffer) @@ -763,7 +763,7 @@ y-point)) (if (not (and (fix:<= 0 y-point) (fix:< y-point (window-y-size window)))) - (error:datum-out-of-range y-point 'window-scroll-y-absolute!)) + (error:bad-range-argument y-point 'WINDOW-SCROLL-Y-ABSOLUTE!)) (with-values (lambda () (predict-start-line window (%window-point-index window) y-point)) diff --git a/v7/src/edwin/comman.scm b/v7/src/edwin/comman.scm index 6999c4275..d5d29dd72 100644 --- a/v7/src/edwin/comman.scm +++ b/v7/src/edwin/comman.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.63 1990/11/02 03:23:13 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comman.scm,v 1.64 1991/02/15 18:12:40 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -143,7 +143,7 @@ (define (check-variable-value-validity! variable value) (if (not (variable-value-valid? variable value)) - (error:illegal-datum value 'CHECK-VARIABLE-VALUE-VALIDITY))) + (error:datum-out-of-range value))) (define (variable-value-valid? variable value) (or (not (variable-value-validity-test variable)) diff --git a/v7/src/edwin/comred.scm b/v7/src/edwin/comred.scm index be5e0ec6d..2c2f34fe4 100644 --- a/v7/src/edwin/comred.scm +++ b/v7/src/edwin/comred.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.83 1990/10/03 04:54:25 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comred.scm,v 1.84 1991/02/15 18:12:46 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -103,7 +103,9 @@ (*command-char*) (*command*) (*next-message* false)) - (start-next-command))))) + (bind-condition-handler (list condition-type:editor-error) + editor-error-handler + start-next-command))))) (define (start-next-command) (reset-command-state!) diff --git a/v7/src/edwin/comwin.scm b/v7/src/edwin/comwin.scm index 044bc9ec8..99a95ccdf 100644 --- a/v7/src/edwin/comwin.scm +++ b/v7/src/edwin/comwin.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comwin.scm,v 1.139 1990/11/02 03:23:19 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/comwin.scm,v 1.140 1991/02/15 18:12:54 cph Exp $ ;;; -;;; Copyright (c) 1985, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1985, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -148,7 +148,7 @@ (define-integrable (check-leaf-window window name) (if (not (leaf? window)) - (error:illegal-datum window name))) + (error:wrong-type-argument window "window" name))) ;;;; Leaf Ordering @@ -185,7 +185,7 @@ (define (window0 window) (if (not (and (object? window) (subclass? (object-class window) combination-leaf-window))) - (error:illegal-datum window 'WINDOW0)) + (error:wrong-type-argument window "window" 'WINDOW0)) (window-leftmost-leaf (window-root window))) (define (%window1+ leaf) diff --git a/v7/src/edwin/editor.scm b/v7/src/edwin/editor.scm index 39f866ee0..cd4084563 100644 --- a/v7/src/edwin/editor.scm +++ b/v7/src/edwin/editor.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.199 1990/11/14 15:10:51 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/editor.scm,v 1.200 1991/02/15 18:13:08 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -56,16 +56,20 @@ (current-editor edwin-editor) (recursive-edit-continuation false) (recursive-edit-level 0)) - (editor-grab-display edwin-editor - (lambda (with-editor-ungrabbed) - (let ((message (cmdl-message/null))) - (push-cmdl (lambda (cmdl) - cmdl ;ignore - (top-level-command-reader edwin-initialization) - message) - false - message - (editor-spawn-child-cmdl with-editor-ungrabbed)))))))) + (bind-condition-handler (list condition-type:error) + internal-error-handler + (lambda () + (editor-grab-display edwin-editor + (lambda (with-editor-ungrabbed) + (let ((message (cmdl-message/null))) + (push-cmdl + (lambda (cmdl) + cmdl ;ignore + (top-level-command-reader edwin-initialization) + message) + false + message + (editor-spawn-child-cmdl with-editor-ungrabbed)))))))))) (if edwin-finalization (edwin-finalization)) unspecific) @@ -257,16 +261,14 @@ with the contents of the startup message." (define recursive-edit-level) (define (internal-error-handler condition) - (and (not (condition/internal? condition)) - (error? condition) - (cond ((ref-variable debug-on-internal-error) - (debug-scheme-error condition) - (message "Scheme error") - (%editor-error)) - (debug-internal-errors? - (signal-error condition)) - (else - (exit-editor-and-signal-error condition))))) + (cond ((ref-variable debug-on-internal-error) + (debug-scheme-error condition) + (message "Scheme error") + (%editor-error)) + (debug-internal-errors? + (error condition)) + (else + (exit-editor-and-signal-error condition)))) (define-variable debug-on-internal-error "True means enter debugger if error is signalled while the editor is running. @@ -279,7 +281,39 @@ This does not affect editor errors or evaluation errors." (define (exit-editor-and-signal-error condition) (within-continuation editor-abort (lambda () - (signal-error condition)))) + (error condition)))) + +(define condition-type:editor-error + (make-condition-type 'EDITOR-ERROR condition-type:error '(STRINGS) + (lambda (condition port) + (write-string "Editor error: " port) + (write-string + (message-args->string (access-condition condition 'STRINGS)) + port)))) + +(define editor-error + (let ((signaller + (condition-signaller condition-type:editor-error + '(STRINGS) + standard-error-handler))) + (lambda strings + (signaller strings)))) + +(define (editor-error-handler condition) + (if (ref-variable debug-on-editor-error) + (debug-scheme-error condition) + (let ((strings (access-condition condition 'STRINGS))) + (if (not (null? strings)) + (apply temporary-message strings)))) + (%editor-error)) + +(define-variable debug-on-editor-error + "True means signal Scheme error when an editor error occurs." + false) + +(define (%editor-error) + (editor-beep) + (abort-current-command)) (define (^G-signal) (let ((continuations *^G-interrupt-continuations*)) diff --git a/v7/src/edwin/edwin.pkg b/v7/src/edwin/edwin.pkg index 73b8cd97b..46252206e 100644 --- a/v7/src/edwin/edwin.pkg +++ b/v7/src/edwin/edwin.pkg @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.22 1990/11/14 15:11:14 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/edwin.pkg,v 1.23 1991/02/15 18:13:15 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -511,7 +511,7 @@ MIT in each case. |# (files "rgxcmp") (parent (edwin)) (export (edwin) - error-type:re-compile-pattern + condition-type:re-compile-pattern re-compile-char re-compile-char-set re-compile-pattern @@ -587,6 +587,8 @@ MIT in each case. |# (export (edwin) debug-scheme-error) (import (runtime debugger) + command/condition-report + command/condition-restart command/earlier-reduction command/earlier-subproblem command/frame @@ -604,8 +606,7 @@ MIT in each case. |# command/show-current-frame command/summarize-subproblems dstate/environment-list - make-initial-dstate - show-error-info) + make-initial-dstate) (import (runtime debugger-utilities) hook/debugger-failure hook/debugger-message diff --git a/v7/src/edwin/evlcom.scm b/v7/src/edwin/evlcom.scm index a63bd8d61..9fdd0ccb9 100644 --- a/v7/src/edwin/evlcom.scm +++ b/v7/src/edwin/evlcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.18 1989/08/29 20:04:00 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/evlcom.scm,v 1.19 1991/02/15 18:13:22 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -204,7 +204,7 @@ With an argument, prompts for the evaluation environment." (ref-mode-object prompt-for-expression)))) (define (read-from-string string) - (bind-condition-handler '() evaluation-error-handler + (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () (with-input-from-string string read)))) @@ -241,11 +241,10 @@ may be available. The following commands are special to this mode: (define (evaluation-environment argument) (let ((->environment (lambda (object) - (bind-condition-handler '() + (bind-condition-handler (list condition-type:error) (lambda (condition) - (and (not (condition/internal? condition)) - (error? condition) - (editor-error "Illegal environment: " object))) + condition + (editor-error "Illegal environment: " object)) (lambda () (->environment object)))))) (if argument @@ -289,31 +288,26 @@ may be available. The following commands are special to this mode: environment)) (define (scode-eval-with-history scode environment) - (bind-condition-handler '() evaluation-error-handler + (bind-condition-handler (list condition-type:error) evaluation-error-handler (lambda () (with-new-history (lambda () (extended-scode-eval scode environment)))))) (define (evaluation-error-handler condition) - (and (not (condition/internal? condition)) - (error? condition) - (begin - (if (ref-variable debug-on-evaluation-error) - (debug-scheme-error condition) - (let ((string - (with-output-to-string - (lambda () - ((condition/reporter condition) - condition - (current-output-port)))))) - (if (and (not (string-find-next-char string #\newline)) - (< (string-column-length string 18) 80)) - (message "Evaluation error: " string) - (begin - (string->temporary-buffer string "*Error*") - (message "Evaluation error"))))) - (%editor-error)))) + (if (ref-variable debug-on-evaluation-error) + (debug-scheme-error condition) + (let ((string + (with-string-output-port + (lambda (port) + (write-condition-report condition port))))) + (if (and (not (string-find-next-char string #\newline)) + (< (string-column-length string 18) 80)) + (message "Evaluation error: " string) + (begin + (string->temporary-buffer string "*Error*") + (message "Evaluation error"))))) + (%editor-error)) ;;;; Transcript Buffer diff --git a/v7/src/edwin/filcom.scm b/v7/src/edwin/filcom.scm index 49f72c7c8..66dcb1eda 100644 --- a/v7/src/edwin/filcom.scm +++ b/v7/src/edwin/filcom.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.143 1990/11/21 23:17:35 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/filcom.scm,v 1.144 1991/02/15 18:13:29 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -187,7 +187,8 @@ Argument means don't offer to use auto-save file." (let ((database (with-output-to-transcript-buffer (lambda () - (bind-condition-handler '() evaluation-error-handler + (bind-condition-handler (list condition-type:error) + evaluation-error-handler (lambda () (catch-file-errors (lambda () false) (lambda () diff --git a/v7/src/edwin/fileio.scm b/v7/src/edwin/fileio.scm index 9f76d0b89..b538ceca1 100644 --- a/v7/src/edwin/fileio.scm +++ b/v7/src/edwin/fileio.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.91 1989/04/28 22:49:50 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/fileio.scm,v 1.92 1991/02/15 18:13:37 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -230,15 +230,15 @@ at the end of a file." buffer mode))) (call-with-current-continuation (lambda (continuation) - (bind-condition-handler '() + (bind-condition-handler + (list condition-type:error) (lambda (condition) - (and (not (condition/internal? condition)) - (error? condition) - (begin - (editor-beep) - (message "Error while processing local variable: " - var) - (continuation false)))) + condition + (editor-beep) + (message + "Error while processing local variable: " + var) + (continuation false)) (lambda () (if (string-ci=? var "Eval") (evaluate val) @@ -304,28 +304,29 @@ Otherwise asks confirmation." (editor-error "Attempt to save to a file which you aren't allowed to write")) (begin - (if (not (or (verify-visited-file-modification-time? buffer) - (not (file-exists? truename)) - (prompt-for-yes-or-no? - "Disk file has changed since visited or saved. Save anyway"))) - (editor-error "Save not confirmed")) - (let ((modes - (and (not (buffer-backed-up? buffer)) - (backup-buffer! buffer truename)))) - (require-newline buffer) - (if (not (or writable? modes)) - (begin - (set! modes (file-modes truename)) - (set-file-modes! truename #o777))) - (write-buffer buffer) - (if modes - (bind-condition-handler '() - (lambda (condition) - (and (not (condition/internal? condition)) - (error? condition) - ((condition/continuation condition) unspecific))) - (lambda () - (set-file-modes! truename modes)))))))))) + (if (not (or (verify-visited-file-modification-time? buffer) + (not (file-exists? truename)) + (prompt-for-yes-or-no? + "Disk file has changed since visited or saved. Save anyway"))) + (editor-error "Save not confirmed")) + (let ((modes + (and (not (buffer-backed-up? buffer)) + (backup-buffer! buffer truename)))) + (require-newline buffer) + (if (not (or writable? modes)) + (begin + (set! modes (file-modes truename)) + (set-file-modes! truename #o777))) + (write-buffer buffer) + (if modes + (call-with-current-continuation + (lambda (continuation) + (bind-condition-handler (list condition-type:error) + (lambda (condition) + condition + (continuation unspecific)) + (lambda () + (set-file-modes! truename modes)))))))))))) (define (verify-visited-file-modification-time? buffer) (let ((truename (buffer-truename buffer)) diff --git a/v7/src/edwin/info.scm b/v7/src/edwin/info.scm index e510794b6..c844ad9ec 100644 --- a/v7/src/edwin/info.scm +++ b/v7/src/edwin/info.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.95 1990/10/03 04:55:12 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/info.scm,v 1.96 1991/02/15 18:13:44 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -886,11 +886,10 @@ The name may be an abbreviation of the reference name." (let ((lose (lambda () (editor-error "Malformed index in Info file")))) - (bind-condition-handler '() + (bind-condition-handler (list condition-type:error) (lambda (condition) - (and (not (condition/internal? condition)) - (error? condition) - (lose))) + condition + (lose)) (lambda () (let ((index (with-input-from-mark mark read))) (if (and (integer? index) diff --git a/v7/src/edwin/iserch.scm b/v7/src/edwin/iserch.scm index 10b5a6fe4..9f5787a85 100644 --- a/v7/src/edwin/iserch.scm +++ b/v7/src/edwin/iserch.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.8 1990/10/03 04:55:22 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/iserch.scm,v 1.9 1991/02/15 18:13:52 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -328,10 +328,9 @@ (define (perform-search forward? regexp? text start) (call-with-current-continuation (lambda (continuation) - (bind-condition-handler - (list error-type:re-compile-pattern) + (bind-condition-handler (list condition-type:re-compile-pattern) (lambda (condition) - (continuation (car (condition/irritants condition)))) + (continuation (access-condition condition 'MESSAGE))) (lambda () (intercept-^G-interrupts (lambda () 'ABORT) (lambda () diff --git a/v7/src/edwin/make.scm b/v7/src/edwin/make.scm index a805564b7..37d22a428 100644 --- a/v7/src/edwin/make.scm +++ b/v7/src/edwin/make.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.24 1990/11/15 23:32:46 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/make.scm,v 3.25 1991/02/15 18:13:58 cph Exp $ Copyright (c) 1989, 1990 Massachusetts Institute of Technology @@ -37,4 +37,4 @@ MIT in each case. |# (declare (usual-integrations)) (package/system-loader "edwin" '() 'QUERY) -(add-system! (make-system "Edwin" 3 24 '())) \ No newline at end of file +(add-system! (make-system "Edwin" 3 25 '())) \ No newline at end of file diff --git a/v7/src/edwin/paths.scm b/v7/src/edwin/paths.scm index f747e5583..13a37ef2d 100644 --- a/v7/src/edwin/paths.scm +++ b/v7/src/edwin/paths.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/paths.scm,v 1.7 1990/11/16 01:11:44 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/paths.scm,v 1.8 1991/02/15 18:14:03 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -47,7 +47,7 @@ MIT in each case. |# (pathname-as-directory (string->pathname "edwin"))))) (define (edwin-tutorial-pathname) - (bind-condition-handler (list error-type:open-file) + (bind-condition-handler (list condition-type:open-file-error) (lambda (condition) condition (editor-error "Unable to find TUTORIAL file")) diff --git a/v7/src/edwin/utils.scm b/v7/src/edwin/utils.scm index e9467cb9f..1748bb382 100644 --- a/v7/src/edwin/utils.scm +++ b/v7/src/edwin/utils.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.20 1989/08/29 20:04:08 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/edwin/utils.scm,v 1.21 1991/02/15 18:14:14 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -162,8 +162,8 @@ (define (catch-file-errors if-error thunk) (call-with-current-continuation (lambda (continuation) - (bind-condition-handler - (list error-type:file) + (bind-condition-handler (list condition-type:file-error + condition-type:port-error) (lambda (condition) condition (continuation (if-error))) diff --git a/v7/src/runtime/rgxcmp.scm b/v7/src/runtime/rgxcmp.scm index 65b1306da..518ca5ea9 100644 --- a/v7/src/runtime/rgxcmp.scm +++ b/v7/src/runtime/rgxcmp.scm @@ -1,8 +1,8 @@ ;;; -*-Scheme-*- ;;; -;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.103 1990/10/05 23:54:51 cph Rel $ +;;; $Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rgxcmp.scm,v 1.104 1991/02/15 18:14:08 cph Exp $ ;;; -;;; Copyright (c) 1986, 1989, 1990 Massachusetts Institute of Technology +;;; Copyright (c) 1986, 1989-91 Massachusetts Institute of Technology ;;; ;;; This material was developed by the Scheme project at the ;;; Massachusetts Institute of Technology, Department of @@ -265,8 +265,17 @@ (define-integrable stack-maximum-length re-number-of-registers) -(define error-type:re-compile-pattern - (make-error-type '() "Error compiling regular expression:")) +(define condition-type:re-compile-pattern + (make-condition-type 'RE-COMPILE-PATTERN condition-type:error + '(MESSAGE) + (lambda (condition port) + (write-string "Error compiling regular expression: " port) + (write-string (access-condition condition 'MESSAGE) port)))) + +(define compilation-error + (condition-signaller condition-type:re-compile-pattern + '(MESSAGE) + standard-error-handler)) (define input-list) (define current-byte) @@ -303,7 +312,7 @@ (if fixup-jump (store-jump! fixup-jump re-code:jump (output-position))) (if (not (stack-empty?)) - (error error-type:re-compile-pattern "Unmatched \\(")) + (compilation-error "Unmatched \\(")) (list->string (map ascii->char (cdr output-head)))) (begin (compile-pattern-char) @@ -439,7 +448,7 @@ ((vector-ref pattern-chars (input-peek-1)))) (define (premature-end) - (error error-type:re-compile-pattern "Premature end of regular expression")) + (compilation-error "Premature end of regular expression")) (define (normal-char) (if (if (input-end?) @@ -647,7 +656,7 @@ (define-backslash-char #\( (lambda () (if (stack-full?) - (error error-type:re-compile-pattern "Nesting too deep")) + (compilation-error "Nesting too deep")) (if (fix:< register-number re-number-of-registers) (begin (output-re-code! re-code:start-memory) @@ -665,7 +674,7 @@ (define-backslash-char #\) (lambda () (if (stack-empty?) - (error error-type:re-compile-pattern "Unmatched close paren")) + (compilation-error "Unmatched close paren")) (if fixup-jump (store-jump! fixup-jump re-code:jump (output-position))) (stack-pop! diff --git a/v8/src/compiler/etc/stackp.scm b/v8/src/compiler/etc/stackp.scm index 3a0cda8d0..a6a56fae2 100644 --- a/v8/src/compiler/etc/stackp.scm +++ b/v8/src/compiler/etc/stackp.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/stackp.scm,v 1.5 1988/12/31 06:41:50 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/stackp.scm,v 1.6 1991/02/15 18:14:31 cph Exp $ -Copyright (c) 1987, 1988 Massachusetts Institute of Technology +Copyright (c) 1987-8, 1991 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -41,8 +41,7 @@ MIT in each case. |# (lambda () (write-continuation (if (default-object? continuation) - (or (error-continuation) - (current-proceed-continuation)) + (error-continuation) continuation))))) (if (or (default-object? filename) (not filename)) (do-it) @@ -54,6 +53,12 @@ MIT in each case. |# continuation) n)) +(define (error-continuation) + (let ((condition (nearest-repl/condition))) + (if (not condition) + (error "no error continuation")) + (condition/continuation condition))) + (define (write-continuation continuation) (let write-stack-stream ((stream (continuation->stream continuation)) (n 0)) diff --git a/v8/src/compiler/etc/xcbfdir.scm b/v8/src/compiler/etc/xcbfdir.scm index 6313a01f0..44e8dc2f7 100644 --- a/v8/src/compiler/etc/xcbfdir.scm +++ b/v8/src/compiler/etc/xcbfdir.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/xcbfdir.scm,v 1.5 1991/02/06 02:53:28 jinx Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/compiler/etc/xcbfdir.scm,v 1.6 1991/02/15 18:14:48 cph Exp $ -Copyright (c) 1989, 1990 Massachusetts Institute of Technology +Copyright (c) 1989-91 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -43,36 +43,36 @@ MIT in each case. |# (two (pathname-new-type pathname "tch"))) (call-with-current-continuation (lambda (here) - (bind-condition-handler - '() - (lambda (condition) - (newline) - (display ";; *** Aborting ") - (display pathname) - (display " ***") - (newline) - (condition/write-report condition) - (newline) - (here 'next)) - (lambda () - (let ((touch-created-file?)) - (dynamic-wind - (lambda () - ;; file-touch returns #T if the file did not exist, - ;; it returns #F if it did. - (set! touch-created-file? - (file-touch two))) - (lambda () - (if (and touch-created-file? - (let ((one-time (file-modification-time one))) - (or (not one-time) - (< one-time - (file-modification-time pathname))))) - (processor pathname - (pathname-new-type pathname extension)))) - (lambda () - (if touch-created-file? - (delete-file two))))))))))) + (bind-condition-handler (list condition-type:error) + (lambda (condition) + (let ((port (current-output-port))) + (newline port) + (write-string ";; *** Aborting " port) + (display pathname port) + (write-string " ***" port) + (newline port) + (write-condition-report condition port) + (newline port)) + (here 'next)) + (lambda () + (let ((touch-created-file?)) + (dynamic-wind + (lambda () + ;; file-touch returns #T if the file did not exist, + ;; #F if it did. + (set! touch-created-file? (file-touch two)) + unspecific) + (lambda () + (if (and touch-created-file? + (let ((one-time (file-modification-time one))) + (or (not one-time) + (< one-time + (file-modification-time pathname))))) + (processor pathname + (pathname-new-type pathname extension)))) + (lambda () + (if touch-created-file? + (delete-file two))))))))))) (directory-read (merge-pathnames (pathname-as-directory (->pathname directory)) (->pathname "*.bin"))))) -- 2.25.1