#| -*-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
(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?)
#| -*-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
(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)
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))
#| -*-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
(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")))))
#| -*-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
((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
#| -*-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
((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
#| -*-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
((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
#| -*-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
((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
;;; -*-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
(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 ()
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."
(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)))
(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:
\\[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.
(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)
;;; -*-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
(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
;;; -*-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
(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)))
;;; -*-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
(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))
(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)
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))
;;; -*-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
(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))
;;; -*-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
(*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!)
;;; -*-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
(define-integrable (check-leaf-window window name)
(if (not (leaf? window))
- (error:illegal-datum window name)))
+ (error:wrong-type-argument window "window" name)))
\f
;;;; Leaf Ordering
(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)))
\f
(define (%window1+ leaf)
;;; -*-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
(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)
(define recursive-edit-level)
\f
(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.
(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*))
#| -*-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
(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
(export (edwin)
debug-scheme-error)
(import (runtime debugger)
+ command/condition-report
+ command/condition-restart
command/earlier-reduction
command/earlier-subproblem
command/frame
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
;;; -*-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
(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))))
(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
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))
\f
;;;; Transcript Buffer
;;; -*-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
(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 ()
;;; -*-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
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)
(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))
;;; -*-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
(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)
;;; -*-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
(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 ()
#| -*-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
(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
#| -*-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
(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"))
;;; -*-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
(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)))
;;; -*-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
(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)
(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)
((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?)
(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)
(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!
#| -*-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
(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)
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))
#| -*-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
(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")))))
projects / mit-scheme.git / commitdiff