From 38d0852055efc5d350157542c7d54d5997fa61fb Mon Sep 17 00:00:00 2001 From: Chris Hanson Date: Fri, 15 Feb 1991 18:08:01 +0000 Subject: [PATCH] Changes to error system: * Complete redesign of the error system. Conditions now have named fields like records, and an interface similar to that of the record abstraction. Condition types have single inheritance instead of multiple inheritance; the latter can be implemented with some small effort should someone need it. Significantly richer taxonomy of condition types. New "restart" mechanism like that of Common Lisp. Hooks for overriding default handlers for errors and warnings. * The special forms `error' and `bkpt' have been changed to be procedures. * `error:datum-out-of-range' no longer accepts a second argument; use new procedure `error:bad-range-argument' instead. * `error:illegal-datum' has been eliminated; use either `error:wrong-type-datum' or `error:wrong-type-argument' instead. Changes to REPL: * ";Value" message produced by REPL now prints out a hash number if the value is a pointer object. * New procedure `ve' starts a sub-REPL in a given environment. * New procedure `restart' selects a restart option and invokes it. If invoked with no arguments, it presents a list of options and prompts for the user to select one by number; otherwise it is called with one argument, an option number. * The variable `cmdl-interrupt/abort-top-level/reset?' has been eliminated. * Eliminated "proceed points" and "proceed continuations". These are replaced by new "restarts" mechanism. * `cmdl-message/active' now passes the current cmdl object as an argument to the actor procedure. * The procedures `abort-to-nearest-driver', `abort-to-previous-driver', and `abort-to-top-level-driver' have been eliminated. The procedures `abort->nearest', `abort->previous', and `abort->top-level' have been generalized to accept a string as an argument; use these in place of the eliminated procedures. Other changes: * Debugger has a new command, K, that chooses a restart option and invokes it. * New predicates `interned-symbol?' and `uninterned-symbol?'. --- v7/src/runtime/advice.scm | 61 +- v7/src/runtime/arith.scm | 54 +- v7/src/runtime/contin.scm | 10 +- v7/src/runtime/dbgcmd.scm | 35 +- v7/src/runtime/debug.scm | 215 +++--- v7/src/runtime/dragon4.scm | 6 +- v7/src/runtime/emacs.scm | 47 +- v7/src/runtime/error.scm | 1295 +++++++++++++++++++++---------- v7/src/runtime/gc.scm | 12 +- v7/src/runtime/global.scm | 22 +- v7/src/runtime/hashtb.scm | 6 +- v7/src/runtime/infstr.scm | 31 +- v7/src/runtime/infutl.scm | 6 +- v7/src/runtime/input.scm | 12 +- v7/src/runtime/intrpt.scm | 24 +- v7/src/runtime/io.scm | 23 +- v7/src/runtime/lambda.scm | 8 +- v7/src/runtime/load.scm | 6 +- v7/src/runtime/make.scm | 8 +- v7/src/runtime/numpar.scm | 6 +- v7/src/runtime/pathnm.scm | 8 +- v7/src/runtime/process.scm | 7 +- v7/src/runtime/record.scm | 39 +- v7/src/runtime/rep.scm | 511 ++++++++----- v7/src/runtime/runtime.pkg | 168 ++-- v7/src/runtime/scode.scm | 18 +- v7/src/runtime/scomb.scm | 10 +- v7/src/runtime/syntax.scm | 22 +- v7/src/runtime/uerror.scm | 1437 ++++++++++++++++++++--------------- v7/src/runtime/unsyn.scm | 48 +- v7/src/runtime/unxprm.scm | 10 +- v7/src/runtime/version.scm | 4 +- v7/src/runtime/where.scm | 37 +- v7/src/runtime/x11graph.scm | 7 +- v7/src/runtime/xeval.scm | 13 +- v8/src/runtime/global.scm | 22 +- v8/src/runtime/infstr.scm | 31 +- v8/src/runtime/infutl.scm | 6 +- v8/src/runtime/load.scm | 6 +- v8/src/runtime/make.scm | 8 +- v8/src/runtime/runtime.pkg | 168 ++-- 41 files changed, 2754 insertions(+), 1713 deletions(-) diff --git a/v7/src/runtime/advice.scm b/v7/src/runtime/advice.scm index 9b5ac7167..e272784cc 100644 --- a/v7/src/runtime/advice.scm +++ b/v7/src/runtime/advice.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.7 1990/09/11 20:43:35 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/advice.scm,v 14.8 1991/02/15 18:04:23 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 @@ -220,13 +220,6 @@ MIT in each case. |# ;;; This procedure is called with the newly-created environment as its ;;; argument. -;;; Doing (PROCEED) from within entry or exit advice will cause that -;;; particular piece of advice to be terminated, but any remaining -;;; advice to be executed. Doing (PROCEED value), however, -;;; immediately terminates all advice and returns VALUE as if the -;;; procedure called had generated the value. Returning from a piece -;;; of exit advice is equivalent to doing (PROCEED value) from it. - (define (advised-procedure-wrapper environment) (let ((procedure (ic-environment/procedure environment)) (arguments (ic-environment/arguments environment))) @@ -234,30 +227,27 @@ MIT in each case. |# (lambda (original-body state) (call-with-current-continuation (lambda (continuation) - - (define ((catching-proceeds receiver) advice) - (with-proceed-point - (lambda (proceed-continuation values) - (if (null? values) - (proceed-continuation '()) - (continuation (car values)))) - (lambda () - (receiver advice)))) - - (for-each (catching-proceeds - (lambda (advice) - (advice procedure arguments environment))) - (car state)) - (let ((value (scode-eval original-body environment))) - (for-each (catching-proceeds - (lambda (advice) - (set! value - (advice procedure - arguments - value - environment)))) - (cdr state)) - value))))))) + (bind-restart 'USE-VALUE + "Return a value from the advised procedure." + continuation + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (lambda () + (prompt-for-evaluated-expression "Procedure value"))) + (for-each (lambda (advice) + (with-simple-restart 'CONTINUE + "Continue with advised procedure." + (lambda () + (advice procedure arguments environment)))) + (car state)) + (let ((value (scode-eval original-body environment))) + (for-each (lambda (advice) + (with-simple-restart 'CONTINUE + "Return from advised procedure." + (lambda () + (advice procedure arguments environment)))) + (cdr state)) + value))))))))) ;;;; Primitive Advisors @@ -415,7 +405,10 @@ MIT in each case. |# (define (break-rep environment message . info) (breakpoint (cmdl-message/append - (cmdl-message/active (lambda () (apply trace-display info))) + (cmdl-message/active + (lambda (cmdl) + cmdl + (apply trace-display info))) (cmdl-message/standard message)) environment)) diff --git a/v7/src/runtime/arith.scm b/v7/src/runtime/arith.scm index 26dc327fc..71855c6e8 100644 --- a/v7/src/runtime/arith.scm +++ b/v7/src/runtime/arith.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/arith.scm,v 1.16 1990/09/11 22:06:09 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/arith.scm,v 1.17 1991/02/15 18:04:30 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 @@ -130,7 +130,8 @@ MIT in each case. |# (set-trampoline! 'GENERIC-TRAMPOLINE-ADD complex:+) (set-trampoline! 'GENERIC-TRAMPOLINE-SUBTRACT complex:-) (set-trampoline! 'GENERIC-TRAMPOLINE-MULTIPLY complex:*) - (set-trampoline! 'GENERIC-TRAMPOLINE-DIVIDE complex:/)))) + (set-trampoline! 'GENERIC-TRAMPOLINE-DIVIDE complex:/))) + unspecific) (define flo:significand-digits-base-2) (define flo:significand-digits-base-10) @@ -243,7 +244,7 @@ MIT in each case. |# (int:* answer b) (loop b e answer))))))) ((int:zero? e) 1) - (else (error:datum-out-of-range e 'EXPT)))) + (else (error:bad-range-argument e 'EXPT)))) (define (int:->string n radix) (if (int:integer? n) @@ -265,7 +266,7 @@ MIT in each case. |# (cond ((int:positive? n) (0STRING))) + (error:wrong-type-argument n false 'NUMBER->STRING))) (declare (integrate-operator rat:rational?)) (define (rat:rational? object) @@ -283,11 +284,11 @@ MIT in each case. |# (int:= (ratnum-denominator q) (ratnum-denominator r))) (if (int:integer? r) #f - (error:illegal-datum r '=))) + (error:wrong-type-argument r false '=))) (if (ratnum? r) (if (int:integer? q) #f - (error:illegal-datum q '=)) + (error:wrong-type-argument q false '=)) (int:= q r)))) (define (rat:< q r) @@ -405,7 +406,7 @@ MIT in each case. |# (rat:binary-operator u/u* v/v* (lambda (u v) (if (int:zero? v) - (error:datum-out-of-range v '/) + (error:divide-by-zero '/ (list u v)) (rat:sign-correction u v (lambda (u v) (let ((d (int:gcd u v))) @@ -442,10 +443,10 @@ MIT in each case. |# ((int:negative? v) (make-rational (int:negate v*) (int:negate v))) (else - (error:datum-out-of-range v/v* '/)))) + (error:divide-by-zero '/ (list 1 v/v*))))) (cond ((int:positive? v/v*) (make-rational 1 v/v*)) ((int:negative? v/v*) (make-rational -1 (int:negate v/v*))) - (else (error:datum-out-of-range v/v* '/))))) + (else (error:divide-by-zero '/ (list 1 v/v*)))))) (define-integrable (rat:binary-operator u/u* v/v* int*int int*rat rat*int rat*rat) @@ -476,12 +477,12 @@ MIT in each case. |# (define (rat:numerator q) (cond ((ratnum? q) (ratnum-numerator q)) ((int:integer? q) q) - (else (error:illegal-datum q 'NUMERATOR)))) + (else (error:wrong-type-argument q false 'NUMERATOR)))) (define (rat:denominator q) (cond ((ratnum? q) (ratnum-denominator q)) ((int:integer? q) 1) - (else (error:illegal-datum q 'DENOMINATOR)))) + (else (error:wrong-type-argument q false 'DENOMINATOR)))) (let-syntax ((define-integer-coercion @@ -490,7 +491,8 @@ MIT in each case. |# (COND ((RATNUM? Q) (,coercion (RATNUM-NUMERATOR Q) (RATNUM-DENOMINATOR Q))) ((INT:INTEGER? Q) Q) - (ELSE (ERROR:ILLEGAL-DATUM Q ',operation-name))))))) + (ELSE + (ERROR:WRONG-TYPE-ARGUMENT Q FALSE ',operation-name))))))) (define-integer-coercion rat:floor floor int:floor) (define-integer-coercion rat:ceiling ceiling int:ceiling) (define-integer-coercion rat:truncate truncate int:quotient) @@ -515,7 +517,7 @@ MIT in each case. |# ;; the continued fraction: (rat:+ fx (rat:invert (loop (rat:invert (rat:- y fy)) - (rat:invert (rat:- x fx))))) + (rat:invert (rat:- x fx))))) ;; [X] < X < [X]+1 <= [Y] <= Y so [X]+1 is the answer: (rat:1+ fx))))) (cond ((rat:positive? x) @@ -557,7 +559,7 @@ MIT in each case. |# ((int:positive? e) (exact-method e)) (else 1)))) - (error:datum-out-of-range e 'EXPT))) + (error:bad-range-argument e 'EXPT))) (define (rat:->string q radix) (if (ratnum? q) @@ -729,7 +731,7 @@ MIT in each case. |# (define (real:exact? x) (and (not (flonum? x)) (or (rat:rational? x) - (error:illegal-datum x 'EXACT?)))) + (error:wrong-type-argument x false 'EXACT?)))) (define (real:zero? x) (if (flonum? x) (flo:zero? x) ((copy rat:zero?) x))) @@ -769,7 +771,7 @@ MIT in each case. |# (lambda (q) (if (rat:rational? q) q - (error:illegal-datum q 'INEXACT->EXACT))))) + (error:wrong-type-argument q false 'INEXACT->EXACT))))) (let-syntax ((define-standard-binary @@ -848,7 +850,7 @@ MIT in each case. |# (if (flonum? n) (if (flo:integer? n) (flo:->integer n) - (error:illegal-datum n 'EVEN?)) + (error:wrong-type-argument n false 'EVEN?)) n))) (let-syntax @@ -858,7 +860,7 @@ MIT in each case. |# (lambda (n) `(IF (FLO:INTEGER? ,n) (FLO:->INTEGER ,n) - (ERROR:ILLEGAL-DATUM ,n ',operator-name))))) + (ERROR:WRONG-TYPE-ARGUMENT ,n FALSE ',operator-name))))) `(DEFINE (,name N M) (IF (FLONUM? N) (INT:->FLONUM @@ -943,10 +945,10 @@ MIT in each case. |# ((flo:zero? x) (if (flo:positive? y) x - (error:datum-out-of-range y 'EXPT))) + (error:bad-range-argument y 'EXPT))) ((and (flo:negative? x) (not (flo:integer? y))) - (error:datum-out-of-range x 'EXPT)) + (error:bad-range-argument x 'EXPT)) (else (flo:expt x y)))))) (if (flonum? x) @@ -1031,7 +1033,7 @@ MIT in each case. |# (define (rec:real-arg name x) (if (real:zero? (rec:imag-part x)) (rec:real-part x) - (error:illegal-datum x name))) + (error:wrong-type-argument x false name))) (define (complex:= z1 z2) (if (recnum? z1) @@ -1172,7 +1174,7 @@ MIT in each case. |# ((real:real? z) z) (else - (error:illegal-datum z 'CONJUGATE)))) + (error:wrong-type-argument z false 'CONJUGATE)))) (define (complex:/ z1 z2) (if (recnum? z1) @@ -1470,12 +1472,12 @@ MIT in each case. |# (define (complex:real-part z) (cond ((recnum? z) (rec:real-part z)) ((real:real? z) z) - (else (error:illegal-datum z 'REAL-PART)))) + (else (error:wrong-type-argument z false 'REAL-PART)))) (define (complex:imag-part z) (cond ((recnum? z) (rec:imag-part z)) ((real:real? z) 0) - (else (error:illegal-datum z 'IMAG-PART)))) + (else (error:wrong-type-argument z false 'IMAG-PART)))) (define (complex:magnitude z) (if (recnum? z) @@ -1686,7 +1688,7 @@ MIT in each case. |# (list? radix)) (parse-format-tail (cdr radix))) (else - (error:datum-out-of-range radix 'NUMBER->STRING))))) + (error:bad-range-argument radix 'NUMBER->STRING))))) (define (parse-format-tail tail) (let loop diff --git a/v7/src/runtime/contin.scm b/v7/src/runtime/contin.scm index dfb8e3e61..14e12e2d1 100644 --- a/v7/src/runtime/contin.scm +++ b/v7/src/runtime/contin.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.4 1989/08/15 13:19:35 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/contin.scm,v 14.5 1991/02/15 18:04:39 cph Exp $ -Copyright (c) 1988, 1989 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 @@ -81,7 +81,9 @@ MIT in each case. |# ;; multiprocessors. (define (within-continuation continuation thunk) - (guarantee-continuation continuation) + (if (not (continuation? continuation)) + (error:wrong-type-argument continuation "continuation" + 'WITHIN-CONTINUATION)) (if (without-interrupts (lambda () (let ((method (continuation/invocation-method continuation))) @@ -135,7 +137,7 @@ MIT in each case. |# (define (guarantee-continuation continuation) (if (not (continuation? continuation)) - (error "Illegal continuation" continuation)) + (error:wrong-type-argument continuation "continuation" false)) continuation) (define-integrable (continuation/invocation-method continuation) diff --git a/v7/src/runtime/dbgcmd.scm b/v7/src/runtime/dbgcmd.scm index fff8fd9fe..ad3460c70 100644 --- a/v7/src/runtime/dbgcmd.scm +++ b/v7/src/runtime/dbgcmd.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.10 1990/11/02 02:06:08 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dbgcmd.scm,v 14.11 1991/02/15 18:04:45 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 @@ -62,12 +62,10 @@ MIT in each case. |# (loop (cdr command-set))))))) (define (letter-commands command-set message prompt state) - (with-standard-proceed-point - (lambda () - (push-cmdl letter-commands/driver - (vector command-set prompt state) - message - make-cmdl)))) + (push-cmdl letter-commands/driver + (vector command-set prompt state) + message + make-cmdl)) (define (letter-commands/driver cmdl) (let ((command-set (vector-ref (cmdl/state cmdl) 0)) @@ -101,7 +99,8 @@ MIT in each case. |# (define (standard-exit-command state) state ;ignore - (proceed)) + (continue) + (debugger-failure "Can't exit; use a restart command instead.")) (define (initialize-package!) (set! hook/leaving-command-loop default/leaving-command-loop)) @@ -117,12 +116,18 @@ MIT in each case. |# (define (debug/read-eval-print environment from to prompt) (leaving-command-loop (lambda () - (read-eval-print - environment - (cmdl-message/standard - (string-append - "You are now in " to ". Type C-c C-u to return to " from ".")) - prompt)))) + (with-simple-restart 'CONTINUE + (lambda (port) + (write-string "Return to " port) + (write-string from port) + (write-string "." port)) + (lambda () + (read-eval-print + environment + (cmdl-message/standard + (string-append + "You are now in " to ". Type C-c C-u to return to " from ".")) + prompt)))))) (define (debug/eval expression environment) (leaving-command-loop diff --git a/v7/src/runtime/debug.scm b/v7/src/runtime/debug.scm index 6e99ce2a6..184f6a9fc 100644 --- a/v7/src/runtime/debug.scm +++ b/v7/src/runtime/debug.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.23 1990/09/13 23:43:13 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/debug.scm,v 14.24 1991/02/15 18:04:50 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 @@ -46,59 +46,72 @@ MIT in each case. |# (define debugger:list-breadth-limit 5) (define (debug #!optional object) - (let ((dstate - (make-initial-dstate - (if (default-object? object) - (or (error-continuation) - (current-proceed-continuation)) - object)))) - (letter-commands - command-set - (cmdl-message/active + (if (default-object? object) + (let ((condition (nearest-repl/condition))) + (if condition + (debug-internal condition) + (call-with-current-continuation debug-internal))) + (debug-internal object))) + +(define (debug-internal object) + (let ((dstate (make-initial-dstate object))) + (with-simple-restart 'CONTINUE "Return from DEBUG." (lambda () - (presentation - (lambda () - (let ((n (count-subproblems dstate))) - (write-string "There ") - (write-string (if (= n 1) "is" "are")) - (write-string " ") - (if (> n debugger:count-subproblems-limit) - (begin - (write-string "more than ") - (write debugger:count-subproblems-limit)) - (write n)) - (write-string " subproblem") - (if (not (= n 1)) - (write-string "s"))) - (write-string " on the stack.") - (newline) - (newline) - (print-subproblem dstate))) - (debugger-message - "You are now in the debugger. Type q to quit, ? for commands."))) - "Debug-->" - dstate))) - + (letter-commands + command-set + (cmdl-message/active + (lambda (cmdl) + cmdl + (presentation + (lambda () + (let ((n (count-subproblems dstate))) + (write-string "There ") + (write-string (if (= n 1) "is" "are")) + (write-string " ") + (if (> n debugger:count-subproblems-limit) + (begin + (write-string "more than ") + (write debugger:count-subproblems-limit)) + (write n)) + (write-string " subproblem") + (if (not (= n 1)) + (write-string "s"))) + (write-string " on the stack.") + (newline) + (newline) + (print-subproblem dstate))) + (debugger-message + "You are now in the debugger. Type q to quit, ? for commands."))) + "Debug-->" + dstate))))) + (define (make-initial-dstate object) - (let ((dstate (allocate-dstate))) - (set-dstate/history-state! - dstate - (cond (debugger:use-history? 'ALWAYS) - (debugger:auto-toggle? 'ENABLED) - (else 'DISABLED))) - (let ((stack-frame (coerce-to-stack-frame object))) - (if (not stack-frame) - (error "DEBUG: null continuation" object)) - (set-current-subproblem! dstate stack-frame '())) - dstate)) - -(define (coerce-to-stack-frame object) - (cond ((stack-frame? object) - (stack-frame/skip-non-subproblems object)) - ((continuation? object) - (coerce-to-stack-frame (continuation->stack-frame object))) - (else - (error "DEBUG: illegal argument" object)))) + (let ((make-dstate + (lambda (stack-frame condition) + (let ((dstate (allocate-dstate))) + (set-dstate/history-state! + dstate + (cond (debugger:use-history? 'ALWAYS) + (debugger:auto-toggle? 'ENABLED) + (else 'DISABLED))) + (set-dstate/condition! dstate condition) + (set-current-subproblem! + dstate + (or (stack-frame/skip-non-subproblems stack-frame) + (error "No frames on stack!" stack-frame)) + '()) + dstate)))) + (cond ((condition? object) + (make-dstate + (continuation->stack-frame (condition/continuation object)) + object)) + ((continuation? object) + (make-dstate (continuation->stack-frame object) false)) + ((stack-frame? object) + (make-dstate object false)) + (else + (error:wrong-type-argument object "condition or continuation" + 'DEBUG))))) (define (count-subproblems dstate) (do ((i 0 (1+ i)) @@ -117,7 +130,8 @@ MIT in each case. |# history-state expression subexpression - environment-list) + environment-list + condition) (define (dstate/reduction dstate) (nth-reduction (dstate/reductions dstate) @@ -149,8 +163,10 @@ MIT in each case. |# "Go to a particular subproblem") (#\H ,command/summarize-subproblems "prints a summary (History) of all subproblems") - (#\I ,command/error-info + (#\I ,command/condition-report "redisplay the error message Info") + (#\K ,command/condition-restart + "continue the program using a standard restart option") (#\L ,command/print-expression "(List expression) pretty print the current expression") (#\O ,command/print-environment-procedure @@ -604,47 +620,54 @@ MIT in each case. |# (define (command/enter-where dstate) (with-current-environment dstate debug/where)) -;;;; Error info - -(define (command/error-info dstate) - dstate ;ignore - (show-error-info (error-condition))) - -(define (show-error-info condition) - (if condition - (presentation - (lambda () - (let ((message (condition/message condition)) - (irritants (condition/irritants condition)) - (port (current-output-port))) - (write-string " Message: ") - (write-string message) - (newline) - (if (null? irritants) - (write-string " No irritants") - (begin - (write-string " Irritants: ") - (for-each - (let ((n (- (output-port/x-size port) 4))) - (lambda (irritant) - (newline) - (write-string " ") - (if (error-irritant/noise? irritant) - (begin - (write-string "noise: ") - (write (error-irritant/noise-value irritant))) - (write-string - (let ((result (write-to-string irritant n))) - (if (car result) - (substring-move-right! "..." 0 3 - (cdr result) (- n 3))) - (cdr result)))))) - irritants))) - (newline) - (write-string " Formatted output:") - (newline) - ((condition/reporter condition) condition port)))) - (debugger-failure "No error to report."))) +;;;; Condition commands + +(define (command/condition-report dstate) + (let ((condition (dstate/condition dstate))) + (if condition + (presentation + (lambda () + (write-condition-report condition (current-output-port)))) + (debugger-failure "No condition to report.")))) + +(define (command/condition-restart dstate) + (let ((restarts + (let ((condition (dstate/condition dstate))) + (if condition + (condition/restarts condition) + (bound-restarts))))) + (if (null? restarts) + (debugger-failure "No options to choose from.") + (let ((n-restarts (length restarts)) + (invoke-option + (lambda (n) + (invoke-restart-interactively (list-ref restarts n))))) + (presentation + (lambda () + (let ((port (current-output-port))) + (if (= n-restarts 1) + (begin + (write-string "There is only one option:" port) + (newline port) + (write-restarts restarts port) + (if (prompt-for-confirmation "Use this option") + (invoke-option 0))) + (begin + (write-string "Choose an option by number:" port) + (newline port) + (write-restarts restarts port) + (invoke-option + (prompt-for-nonnegative-integer "Option number" + n-restarts))))))))))) + +(define (write-restarts restarts port) + (do ((restarts restarts (cdr restarts)) + (index 0 (1+ index))) + ((null? restarts)) + (write-string (string-pad-left (number->string index) 3) port) + (write-string ": " port) + (write-restart-report (car restarts) port) + (newline port))) ;;;; Advanced hacking commands diff --git a/v7/src/runtime/dragon4.scm b/v7/src/runtime/dragon4.scm index 26bbb458f..acdcd2938 100644 --- a/v7/src/runtime/dragon4.scm +++ b/v7/src/runtime/dragon4.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dragon4.scm,v 1.5 1990/09/13 20:12:50 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/dragon4.scm,v 1.6 1991/02/15 18:04:59 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 @@ -219,4 +219,4 @@ MIT in each case. |# ((absolute) (cutoff-adjust cutoff)) ((relative) (cutoff-adjust (+ k cutoff))) (else - (error:illegal-datum cutoff-mode 'DRAGON4))))))))))))) \ No newline at end of file + (error:wrong-type-datum cutoff-mode false))))))))))))) \ No newline at end of file diff --git a/v7/src/runtime/emacs.scm b/v7/src/runtime/emacs.scm index d098466f3..94b45c49c 100644 --- a/v7/src/runtime/emacs.scm +++ b/v7/src/runtime/emacs.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.6 1990/09/11 20:44:25 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/emacs.scm,v 14.7 1991/02/15 18:05:04 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 @@ -85,10 +85,19 @@ MIT in each case. |# (if (cmdl/io-to-console? repl) (begin (repl-history/record! (repl/printer-history repl) object) - (transmit-signal-with-argument #\v - (if (undefined-value? object) - "" - (object->string object)))) + (cond ((undefined-value? object) + (transmit-signal-with-argument #\v "")) + ((object-non-pointer? object) + (transmit-signal-with-argument #\v (object->string object))) + (else + ;; The #\P command used to do something useful, but now + ;; it just sets the Emacs variable `xscheme-prompt' to + ;; its string argument. We use this to advantage here. + (transmit-signal-with-argument #\P (object->string object)) + (emacs-eval + "(xscheme-write-message-1 xscheme-prompt (format \";Value " + (number->string (object-hash object)) + ": %s\" xscheme-prompt))")))) (normal/repl-write repl object))) (define (emacs/cmdl-message cmdl string) @@ -104,17 +113,10 @@ MIT in each case. |# (let ((entry (assoc prompt cmdl-prompt-alist))) (if entry (cdr entry) - prompt))))) + "[Evaluator]"))))) (define cmdl-prompt-alist - '(("]=>" . "[Normal REPL]") - ("==>" . "[Normal REPL]") - ("Eval-in-env-->" . "[Normal REPL]") - ("Bkpt->" . "[Breakpoint REPL]") - ("Error->" . "[Error REPL]") - ("Debugger-->" . "[Debugger REPL]") - ("Visiting->" . "[Visiting environment]") - ("Debug-->" . "[Debugger]") + '(("Debug-->" . "[Debugger]") ("Where-->" . "[Environment Inspector]") ("Which-->" . "[Task Inspector]"))) @@ -146,9 +148,7 @@ MIT in each case. |# (transmit-signal-without-gc #\z) (beep console-output-port) (if paranoid-error-decision? - (begin - (transmit-signal-with-argument #\P "Error!") - (abort-to-previous-driver "Quit!")))) + (cmdl-interrupt/abort-previous))) (define paranoid-error-decision? false) @@ -173,8 +173,7 @@ MIT in each case. |# (define (emacs/prompt-for-confirmation cmdl prompt) (if (cmdl/io-to-console? cmdl) (begin - (transmit-signal-with-argument #\n - (string-append prompt " (y or n)? ")) + (transmit-signal-with-argument #\n (string-append prompt "? ")) (char=? #\y (read-char-internal))) (normal/prompt-for-confirmation cmdl prompt))) @@ -213,11 +212,11 @@ MIT in each case. |# (define normal/gc-finish) (define normal/cmdl-message) (define normal/cmdl-prompt) +(define normal/error-decision) (define normal/repl-write) (define normal/repl-read) (define normal/read-start) (define normal/read-finish) -(define normal/error-decision) (define normal/read-command-char) (define normal/prompt-for-confirmation) (define normal/prompt-for-expression) @@ -233,11 +232,11 @@ MIT in each case. |# (set! normal/gc-finish hook/gc-finish) (set! normal/cmdl-message hook/cmdl-message) (set! normal/cmdl-prompt hook/cmdl-prompt) + (set! normal/error-decision hook/error-decision) (set! normal/repl-write hook/repl-write) (set! normal/repl-read hook/repl-read) (set! normal/read-start hook/read-start) (set! normal/read-finish hook/read-finish) - (set! normal/error-decision hook/error-decision) (set! normal/read-command-char hook/read-command-char) (set! normal/prompt-for-confirmation hook/prompt-for-confirmation) (set! normal/prompt-for-expression hook/prompt-for-expression) @@ -261,11 +260,11 @@ MIT in each case. |# (set! hook/gc-finish emacs/gc-finish) (set! hook/cmdl-message emacs/cmdl-message) (set! hook/cmdl-prompt emacs/cmdl-prompt) + (set! hook/error-decision emacs/error-decision) (set! hook/repl-write emacs/repl-write) (set! hook/repl-read emacs/repl-read) (set! hook/read-start emacs/read-start) (set! hook/read-finish emacs/read-finish) - (set! hook/error-decision emacs/error-decision) (set! hook/read-command-char emacs/read-command-char) (set! hook/prompt-for-confirmation emacs/prompt-for-confirmation) (set! hook/prompt-for-expression emacs/prompt-for-expression) @@ -283,11 +282,11 @@ MIT in each case. |# (set! hook/gc-finish normal/gc-finish) (set! hook/cmdl-message normal/cmdl-message) (set! hook/cmdl-prompt normal/cmdl-prompt) + (set! hook/error-decision normal/error-decision) (set! hook/repl-write normal/repl-write) (set! hook/repl-read normal/repl-read) (set! hook/read-start normal/read-start) (set! hook/read-finish normal/read-finish) - (set! hook/error-decision normal/error-decision) (set! hook/read-command-char normal/read-command-char) (set! hook/prompt-for-confirmation normal/prompt-for-confirmation) (set! hook/prompt-for-expression normal/prompt-for-expression) diff --git a/v7/src/runtime/error.scm b/v7/src/runtime/error.scm index b84e5eabf..731ab88e2 100644 --- a/v7/src/runtime/error.scm +++ b/v7/src/runtime/error.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.10 1990/06/28 18:10:05 jinx Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/error.scm,v 14.11 1991/02/15 18:05:10 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 @@ -37,419 +37,946 @@ MIT in each case. |# (declare (usual-integrations)) -(define (initialize-package!) - (set! next-condition-type-index 0) - (set! handler-frames false) - (set! condition-type:error - (let ((generalizations (list false))) - (let ((result - (%make-condition-type generalizations - true - condition-reporter/default))) - (set-car! generalizations result) - result))) - (set! condition-type:microcode-asynchronous - (make-condition-type '() "Microcode asynchronous")) - (set! condition-type:hardware-trap - (make-condition-type (list condition-type:microcode-asynchronous) - "Hardware trap")) - (set! condition-type:user-microcode-reset - (make-condition-type (list condition-type:microcode-asynchronous) - "User microcode reset")) - (set! error-type:vanilla - (make-condition-type (list condition-type:error) - condition-reporter/default)) - (set! hook/error-handler default/error-handler) - (set! hook/error-decision default/error-decision) - (set! hook/hardware-trap recover/hardware-trap) - (let ((fixed-objects (get-fixed-objects-vector))) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'ERROR-PROCEDURE) - error-procedure-handler) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) - error-from-compiled-code) - ((ucode-primitive set-fixed-objects-vector!) fixed-objects))) - -(define (error-procedure-handler message irritants environment) - (with-proceed-point proceed-value-filter - (lambda () - (simple-error environment message irritants)))) - -(define (error-from-compiled-code message . irritants) - (with-proceed-point proceed-value-filter - (lambda () - (simple-error repl-environment message irritants)))) - -(define (recover/hardware-trap name) - (call-with-current-continuation - (lambda (trap-continuation) - (signal-error - (make-condition - (if name - condition-type:hardware-trap - condition-type:user-microcode-reset) - (if (not name) - '() - (let ((code - (let ((stack-frame - (continuation/first-subproblem trap-continuation))) - (and (hardware-trap-frame? stack-frame) - (hardware-trap-frame/code stack-frame))))) - `(,(error-irritant/noise " ") - ,(error-irritant/noise name) - ,@(if code - (list (error-irritant/noise ": ") - (error-irritant/noise code)) - '())))) - trap-continuation))))) - -;;; (PROCEED) means retry error expression, (PROCEED value) means -;;; return VALUE as the value of the error subproblem. - -(define (proceed-value-filter continuation values) - (let ((default (lambda () (continuation unspecific)))) - (if (null? values) - (default) - (let ((first-subproblem (continuation/first-subproblem continuation))) - (if first-subproblem - (let ((next-subproblem (stack-frame/next first-subproblem))) - (if next-subproblem - ((stack-frame->continuation next-subproblem) (car values)) - (default))) - (default)))))) - -(define (simple-error environment message irritants) - (signal-error - (if (condition-type? message) - (make-error-condition message irritants environment) - ;; This handles old and "vanilla" errors. - (let ((condition - (make-error-condition error-type:vanilla - irritants - environment))) - (if (string? message) - (1d-table/put! (condition/properties condition) - message-tag - message)) - condition)))) - -(define (make-error-condition condition-type irritants environment) - ;; Microcode errors also use this. - (let ((condition - (make-condition condition-type - irritants - (current-proceed-continuation)))) - (1d-table/put! (condition/properties condition) - environment-tag - (if (eq? environment repl-environment) - (cons (nearest-repl/environment) true) - (cons environment false))) - condition)) - -(define message-tag - "message-tag") - -(define environment-tag - "environment-tag") - -(define repl-environment - "repl-environment") - -(define error-type:vanilla) - -(define (condition-reporter/default condition port) - (format-error-message (condition/message condition) - (condition/irritants condition) - port)) - -(define (condition/message condition) - (or (1d-table/get (condition/properties condition) message-tag false) - (1d-table/get (condition-type/properties (condition/type condition)) - message-tag - "Anonymous error"))) - -(define (condition/environment condition) - (let ((place (1d-table/get (condition/properties condition) - environment-tag false))) - (if (not place) - (nearest-repl/environment) - (car place)))) - -(define (condition/substitute-environment? condition) - (let ((place (1d-table/get (condition/properties condition) - environment-tag false))) - (or (not place) - (cdr place)))) - -;;;; Standard Error Handler - -(define (standard-error-handler condition) - (fluid-let ((*error-condition* condition)) - (hook/error-handler condition))) - -(define hook/error-handler) -(define (default/error-handler condition) - (push-repl (condition/environment condition) - (let ((message - (cmdl-message/append - (cmdl-message/strings (condition/report-string condition)) - (cmdl-message/active hook/error-decision)))) - (if (condition/substitute-environment? condition) - (cmdl-message/append - message - (cmdl-message/strings - "" - "There is no environment available;" - "using the current REPL environment")) - message)) - "Error->")) - -(define hook/error-decision) -(define (default/error-decision) - false) - -(define *error-condition* false) - -(define-integrable (error-condition) - *error-condition*) - -(define (error-continuation) - (let ((condition (error-condition))) - (and condition - (condition/continuation condition)))) - -(define-integrable (error-message) - (condition/message (error-condition))) - -(define-integrable (error-irritants) - (condition/irritants (error-condition))) - -;;;; Error Messages - -(define (warn string . irritants) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Warning: " port) - (format-error-message string irritants port))) - -(define-integrable (error-irritants/sans-noise) - (list-transform-negative (error-irritants) - error-irritant/noise?)) - -(define (error-irritant) - (let ((irritants (error-irritants/sans-noise))) - (cond ((null? irritants) *the-non-printing-object*) - ((null? (cdr irritants)) (car irritants)) - (else irritants)))) - -(define (cmdl-message/error string . irritants) - (cmdl-message/strings - (if (null? irritants) - string - (with-output-to-string - (lambda () - (format-error-message string irritants (current-output-port))))))) - -(define (format-error-message message irritants port) - (fluid-let ((*unparser-list-depth-limit* 2) - (*unparser-list-breadth-limit* 5)) - (for-each (lambda (irritant) - (if (error-irritant/noise? irritant) - (display (error-irritant/noise-value irritant) port) - (begin - (write-char #\Space port) - (write irritant port)))) - (cons (if (string? message) - (error-irritant/noise message) - message) - irritants)))) - -(define-integrable (error-irritant/noise noise) - (cons error-irritant/noise-tag noise)) - -(define (error-irritant/noise? irritant) - (and (pair? irritant) - (eq? (car irritant) error-irritant/noise-tag))) - -(define-integrable (error-irritant/noise-value irritant) - (cdr irritant)) - -(define error-irritant/noise-tag - "error-irritant/noise") - ;;;; Condition Types (define-structure (condition-type + (conc-name %condition-type/) (constructor %make-condition-type - (generalizations error? reporter)) - (conc-name condition-type/)) - ;; `generalizations' is sorted in decreasing `index' order. - (generalizations false read-only true) - (error? false read-only true) + (name field-indexes reporter)) + (print-procedure + (unparser/standard-method 'CONDITION-TYPE + (lambda (state type) + (unparse-string state (%condition-type/name type)))))) + (name false read-only true) + generalizations + (field-indexes false read-only true) + (number-of-fields (length field-indexes) read-only true) (reporter false read-only true) - (index (allocate-condition-type-index!) read-only true) (properties (make-1d-table) read-only true)) -(define (make-condition-type generalizations reporter) - (for-each guarantee-condition-type generalizations) - (let ((generalizations - (cons false - (reduce generalizations/union - '() - (map condition-type/generalizations generalizations))))) - (let ((result - (%make-condition-type - generalizations - (if (memq condition-type:error generalizations) true false) - (if (string? reporter) condition-reporter/default reporter)))) - (set-car! generalizations result) - (if (string? reporter) - (1d-table/put! (condition-type/properties result) - message-tag - reporter)) - result))) - -(define (allocate-condition-type-index!) - (let ((index next-condition-type-index)) - (set! next-condition-type-index (1+ index)) - index)) - -(define next-condition-type-index) - -(define (guarantee-condition-type object) - (if (not (condition-type? object)) (error "Illegal condition-type" object)) - object) - -(define-integrable (condition-typestring name)) + ((false? name) "(anonymous)") + (else + (error:wrong-type-argument name "condition-type name" + 'MAKE-CONDITION-TYPE))) + (let ((old-indexes + (if generalization + (%condition-type/field-indexes generalization) + '()))) + (do ((old-indexes old-indexes (cdr old-indexes)) + (indexes (do ((field-names field-names (cdr field-names)) + (index (length old-indexes) (1+ index)) + (indexes '() + (cons (cons (car field-names) index) + indexes))) + ((null? field-names) + indexes)) + (let ((entry (car old-indexes))) + (if (assq (car entry) indexes) + indexes + (cons entry indexes))))) + ((null? old-indexes) + (reverse! indexes)))) + (cond ((string? reporter) + (lambda (condition port) + condition + (write-string reporter port))) + ((procedure-of-arity? reporter 2) + reporter) + ((false? reporter) + (if generalization + (%condition-type/reporter generalization) + (lambda (condition port) + (write-string "undocumented condition of type " port) + (write (%condition/type condition) port)))) + (else + (error:wrong-type-argument reporter "condition-type reporter" + 'MAKE-CONDITION-TYPE)))))) + (set-%condition-type/generalizations! + type + (cons type + (if generalization + (%condition-type/generalizations generalization) + '()))) + type)) -(define (generalizations/union x y) - ;; This takes advantage of (and preserves) the ordering of generalizations. - (cond ((null? x) y) - ((null? y) x) - ((eq? (car x) (car y)) - (cons (car x) (generalizations/union (cdr x) (cdr y)))) - ((condition-type")) + +(define (standard-warning-handler condition) + (let ((hook standard-warning-hook)) + (if hook + (fluid-let ((standard-warning-hook false)) + (hook condition)) + (let ((port (nearest-cmdl/output-port))) + (newline port) + (write-string "Warning: " port) + (write-condition-report condition port))))) + +(define standard-error-hook false) +(define standard-warning-hook false) + +(define (condition-signaller type field-names default-handler) + (guarantee-condition-handler default-handler 'CONDITION-SIGNALLER) + (let ((make-condition (condition-constructor type field-names))) + (lambda field-values + (call-with-current-continuation + (lambda (continuation) + (let ((condition + (apply make-condition + continuation + 'BOUND-RESTARTS + field-values))) + (signal-condition condition) + (default-handler condition))))))) + +;;;; Basic Condition Types + +(define condition-type:arithmetic-error) +(define condition-type:bad-range-argument) +(define condition-type:cell-error) +(define condition-type:control-error) +(define condition-type:datum-out-of-range) +(define condition-type:derived-port-error) +(define condition-type:divide-by-zero) +(define condition-type:error) +(define condition-type:file-error) +(define condition-type:file-touch-error) +(define condition-type:floating-point-overflow) +(define condition-type:floating-point-underflow) +(define condition-type:illegal-datum) +(define condition-type:no-such-restart) +(define condition-type:open-file-error) +(define condition-type:port-error) +(define condition-type:serious-condition) +(define condition-type:simple-condition) +(define condition-type:simple-error) +(define condition-type:simple-warning) +(define condition-type:unassigned-variable) +(define condition-type:unbound-variable) +(define condition-type:variable-error) +(define condition-type:warning) +(define condition-type:wrong-number-of-arguments) +(define condition-type:wrong-type-argument) +(define condition-type:wrong-type-datum) + +(define make-simple-error) +(define make-simple-warning) + +(define error:bad-range-argument) +(define error:datum-out-of-range) +(define error:divide-by-zero) +(define error:file-touch) +(define error:no-such-restart) +(define error:open-file) +(define error:derived-port) +(define error:wrong-number-of-arguments) +(define error:wrong-type-argument) +(define error:wrong-type-datum) + +(define (condition-type/error? type) + (guarantee-condition-type type 'CONDITION-TYPE/ERROR?) + (%condition-type/error? type)) + +(define (condition/error? condition) + (guarantee-condition condition 'CONDITION/ERROR?) + (%condition-type/error? (%condition/type condition))) + +(define-integrable (%condition-type/error? type) + (memq condition-type:error (%condition-type/generalizations type))) -;;;; Condition Handling +(define (initialize-package!) + (set! condition-type:serious-condition + (make-condition-type 'SERIOUS-CONDITION false '() false)) + (set! condition-type:warning + (make-condition-type 'WARNING false '() false)) -(define handler-frames) + (set! condition-type:error + (make-condition-type 'ERROR condition-type:serious-condition '() + false)) + + (let ((reporter/simple-condition + (lambda (condition port) + (format-error-message (access-condition condition 'MESSAGE) + (access-condition condition 'IRRITANTS) + port)))) + (set! condition-type:simple-condition + (make-condition-type 'SIMPLE-CONDITION false '(MESSAGE IRRITANTS) + reporter/simple-condition)) + (set! condition-type:simple-error + (make-condition-type 'SIMPLE-ERROR condition-type:error + '(MESSAGE IRRITANTS) + reporter/simple-condition)) + (set! condition-type:simple-warning + (make-condition-type 'SIMPLE-WARNING condition-type:warning + '(MESSAGE IRRITANTS) + reporter/simple-condition))) + + (set! condition-type:illegal-datum + (make-condition-type 'ILLEGAL-DATUM condition-type:error '(DATUM) + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-string " has been found in an inappropriate context." + port)))) + + (set! condition-type:datum-out-of-range + (make-condition-type 'DATUM-OUT-OF-RANGE condition-type:illegal-datum + '() + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-string " is not in the correct range." port)))) + + (let ((write-type-description + (let ((char-set:vowels + (char-set #\a #\e #\i #\o #\u #\A #\E #\I #\O #\U))) + (lambda (condition port) + (let ((type (access-condition condition 'TYPE))) + (if (string? type) + (begin + (if (and (not (string-null? type)) + (not (or (string-prefix-ci? "a " type) + (string-prefix-ci? "an " type)))) + (write-string + (if (char-set-member? char-set:vowels + (string-ref type 0)) + "an " + "a ") + port)) + (write-string type port)) + (write-string "the correct type" port)))))) + (write-operand-description + (lambda (condition port) + (let ((operator (access-condition condition 'OPERATOR)) + (operand (access-condition condition 'OPERAND))) + (if (or (symbol? operator) + (procedure? operator)) + (begin + (write-string ", passed " port) + (cond ((symbol? operand) + (write-string "as the argument " port) + (write operand port)) + ((exact-nonnegative-integer? operand) + (write-string "as the " port) + (write-string (ordinal-number-string (+ operand 1)) + port) + (write-string " argument" port)) + (else + (write-string "as an argument" port))) + (write-string " to " port) + (write-operator operator port) + (write-string "," port))))))) + (set! condition-type:wrong-type-datum + (make-condition-type 'WRONG-TYPE-DATUM condition-type:illegal-datum + '(TYPE) + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-string " is not " port) + (write-type-description condition port) + (write-string "." port)))) + (set! condition-type:wrong-type-argument + (make-condition-type 'WRONG-TYPE-ARGUMENT + condition-type:wrong-type-datum + '(OPERATOR OPERAND) + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-operand-description condition port) + (write-string " is not " port) + (write-type-description condition port) + (write-string "." port)))) + (set! condition-type:bad-range-argument + (make-condition-type 'BAD-RANGE-ARGUMENT + condition-type:datum-out-of-range + '(OPERATOR OPERAND) + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-operand-description condition port) + (write-string " is not in the correct range." port))))) + + (set! condition-type:wrong-number-of-arguments + (make-condition-type 'WRONG-NUMBER-OF-ARGUMENTS + condition-type:wrong-type-datum + '(OPERANDS) + (lambda (condition port) + (write-string "The procedure " port) + (write-operator (access-condition condition 'DATUM) port) + (write-string " has been called with " port) + (write (length (access-condition condition 'OPERANDS)) port) + (write-string " arguments; it requires " port) + (let ((arity (access-condition condition 'TYPE))) + (cond ((not (pair? arity)) + (write-string "exactly " port) + (write arity port)) + ((not (cdr arity)) + (write-string "at least " port) + (write (car arity) port)) + ((= (car arity) (cdr arity)) + (write-string "exactly " port) + (write (car arity) port)) + (else + (write-string "between " port) + (write (car arity) port) + (write-string " and " port) + (write (cdr arity) port)))) + (write-string " arguments." port)))) + + (set! condition-type:control-error + (make-condition-type 'CONTROL-ERROR condition-type:error '() + "Control error.")) + + (set! condition-type:no-such-restart + (make-condition-type 'NO-SUCH-RESTART condition-type:control-error + '(NAME) + (lambda (condition port) + (write-string "The restart named " port) + (write (access-condition condition 'NAME) port) + (write-string " is not bound." port)))) + + (let ((anonymous-error + (lambda (type-name field-name) + (make-condition-type type-name condition-type:error + (list field-name) + (lambda (condition port) + (write-string "Anonymous error associated with " port) + (write (access-condition condition field-name) port) + (write-string "." port)))))) + (set! condition-type:port-error (anonymous-error 'PORT-ERROR 'PORT)) + (set! condition-type:file-error (anonymous-error 'FILE-ERROR 'FILENAME)) + (set! condition-type:cell-error (anonymous-error 'CELL-ERROR 'LOCATION))) + + (set! condition-type:derived-port-error + (make-condition-type 'DERIVED-PORT-ERROR condition-type:port-error + '(CONDITION) + (lambda (condition port) + (write-string "The port " port) + (write (access-condition condition 'PORT) port) + (write-string " received an error:" port) + (newline port) + (write-condition-report (access-condition condition 'CONDITION) + port)))) + + (set! error:derived-port + (let ((make-condition + (condition-constructor condition-type:derived-port-error + '(PORT CONDITION)))) + (lambda (port condition) + (guarantee-condition condition 'ERROR:DERIVED-PORT) + (error (make-condition (%condition/continuation condition) + (%condition/restarts condition) + port + condition))))) + + (set! condition-type:open-file-error + (make-condition-type 'OPEN-FILE-ERROR condition-type:file-error '() + (lambda (condition port) + (write-string "Unable to open file " port) + (write (access-condition condition 'FILENAME) port) + (write-string "." port)))) + + (set! condition-type:file-touch-error + (make-condition-type 'FILE-TOUCH-ERROR condition-type:file-error + '(MESSAGE) + (lambda (condition port) + (write-string "The primitive file-touch signalled an error: " port) + (write (access-condition condition 'MESSAGE) port) + (write-string "." port)))) + + (set! condition-type:variable-error + (make-condition-type 'VARIABLE-ERROR condition-type:cell-error + '(ENVIRONMENT) + (lambda (condition port) + (write-string "Anonymous error associated with variable " port) + (write (access-condition condition 'LOCATION) port) + (write-string "." port)))) + + (set! condition-type:unbound-variable + (make-condition-type 'UNBOUND-VARIABLE condition-type:variable-error + '() + (lambda (condition port) + (write-string "Unbound variable: " port) + (write (access-condition condition 'LOCATION) port)))) + + (set! condition-type:unassigned-variable + (make-condition-type 'UNASSIGNED-VARIABLE condition-type:variable-error + '() + (lambda (condition port) + (write-string "Unassigned variable: " port) + (write (access-condition condition 'LOCATION) port)))) + + (let ((arithmetic-error-report + (lambda (description) + (lambda (condition port) + (write-string description port) + (let ((operator (access-condition condition 'OPERATOR))) + (if operator + (begin + (write-string " signalled by " port) + (write-operator operator port) + (write-string "." port)))))))) + (set! condition-type:arithmetic-error + (make-condition-type 'ARITHMETIC-ERROR condition-type:error + '(OPERATOR OPERANDS) + (arithmetic-error-report "Anonymous arithmetic error"))) + (set! condition-type:divide-by-zero + (make-condition-type 'DIVIDE-BY-ZERO condition-type:arithmetic-error + '() + (arithmetic-error-report "Division by zero"))) + (set! condition-type:floating-point-overflow + (make-condition-type 'FLOATING-POINT-OVERFLOW + condition-type:arithmetic-error + '() + (arithmetic-error-report "Floating-point overflow"))) + (set! condition-type:floating-point-underflow + (make-condition-type 'FLOATING-POINT-UNDERFLOW + condition-type:arithmetic-error + '() + (arithmetic-error-report "Floating-point underflow")))) + + (set! make-simple-error + (condition-constructor condition-type:simple-error + '(MESSAGE IRRITANTS))) + (set! make-simple-warning + (condition-constructor condition-type:simple-warning + '(MESSAGE IRRITANTS))) + + (set! error:wrong-type-datum + (condition-signaller condition-type:wrong-type-datum + '(DATUM TYPE) + standard-error-handler)) + (set! error:datum-out-of-range + (condition-signaller condition-type:datum-out-of-range + '(DATUM) + standard-error-handler)) + (set! error:wrong-type-argument + (condition-signaller condition-type:wrong-type-argument + '(DATUM TYPE OPERATOR) + standard-error-handler)) + (set! error:bad-range-argument + (condition-signaller condition-type:bad-range-argument + '(DATUM OPERATOR) + standard-error-handler)) + (set! error:wrong-number-of-arguments + (condition-signaller condition-type:wrong-number-of-arguments + '(DATUM TYPE OPERANDS) + standard-error-handler)) + (set! error:divide-by-zero + (condition-constructor condition-type:divide-by-zero + '(OPERATOR OPERANDS))) + (set! error:no-such-restart + (condition-signaller condition-type:no-such-restart + '(NAME) + standard-error-handler)) + (set! error:open-file + (condition-signaller condition-type:open-file-error + '(FILENAME) + standard-error-handler)) + (set! error:file-touch + (condition-signaller condition-type:file-touch-error + '(FILENAME MESSAGE) + standard-error-handler)) + + unspecific) + +;;;; Utilities -(define-structure (handler-frame (type structure) - (conc-name handler-frame/)) - (condition-types false read-only true) - (handler false read-only true) - (next false read-only true)) +(define (format-error-message message irritants port) + (fluid-let ((*unparser-list-depth-limit* 2) + (*unparser-list-breadth-limit* 5)) + (for-each (lambda (irritant) + (if (and (pair? irritant) + (eq? (car irritant) error-irritant/noise-tag)) + (display (cdr irritant) port) + (begin + (write-char #\space port) + (write irritant port)))) + (cons (if (string? message) + (error-irritant/noise message) + message) + irritants)))) -(define (bind-condition-handler condition-types handler thunk) - (for-each guarantee-condition-type condition-types) - (fluid-let ((handler-frames - (make-handler-frame condition-types - handler - handler-frames))) - (thunk))) +(define-integrable (error-irritant/noise noise) + (cons error-irritant/noise-tag noise)) -(define-integrable (signal-error condition) - (signal-condition condition standard-error-handler)) - -(define (signal-condition condition #!optional default-handler) - (guarantee-condition condition) - (let ((condition-type (condition/type condition))) - (let ((generalizations (condition-type/generalizations condition-type))) - (or (scan-handler-frames handler-frames generalizations - (lambda (frame) - (fluid-let ((handler-frames (handler-frame/next frame))) - ((handler-frame/handler frame) condition)))) - (and (not (default-object? default-handler)) - (fluid-let ((handler-frames false)) - (default-handler condition))))))) - -(define (scan-handler-frames frames generalizations try-frame) - (let loop ((frame frames)) - (and frame - (or (and (let ((condition-types - (handler-frame/condition-types frame))) - (or (null? condition-types) - (generalizations/intersect? generalizations - condition-types))) - (try-frame frame)) - (loop (handler-frame/next frame)))))) \ No newline at end of file +(define error-irritant/noise-tag + '(error-irritant/noise)) + +(define (ordinal-number-string n) + (if (not (and (exact-nonnegative-integer? n) (< n 100))) + (error:wrong-type-argument n "exact integer between 0 and 99" + 'ORDINAL-NUMBER-STRING)) + (let ((ones-names + #("zeroth" "first" "second" "third" "fourth" "fifth" "sixth" + "seventh" "eighth" "ninth")) + (tens-names #("twen" "thir" "for" "fif" "six" "seven" "eigh" "nine"))) + (cond ((< n 10) (vector-ref ones-names n)) + ((< n 20) + (vector-ref #("tenth" "eleventh" "twelfth" "thirteenth" "fourteenth" + "fifteenth" "sixteenth" "seventeenth" + "eighteenth" "nineteenth") + (- n 10))) + (else + (let ((qr (integer-divide n 10))) + (string-append + (vector-ref tens-names (- (integer-divide-quotient qr) 2)) + (let ((ones (integer-divide-remainder qr))) + (if (zero? ones) + "tieth" + (string-append "ty-" (vector-ref ones-names ones)))))))))) + +(define (write-operator operator port) + (write (if (primitive-procedure? operator) + (primitive-procedure-name operator) + operator) + port)) + +(define-integrable (guarantee-list-of-symbols object operator) + (if (not (list-of-symbols? object)) + (error:wrong-type-argument object "list of unique symbols" operator))) + +(define (list-of-symbols? object) + (and (list? object) + (let loop ((field-names object)) + (or (null? field-names) + (and (symbol? (car field-names)) + (not (memq (car field-names) (cdr field-names))) + (loop (cdr field-names))))))) + +(define-integrable (guarantee-keyword-association-list object operator) + (if (not (keyword-association-list? object)) + (error:wrong-type-argument object "keyword association list" operator))) + +(define (keyword-association-list? object) + (and (list? object) + (let loop ((l object) (symbols '())) + (or (null? l) + (and (symbol? (car l)) + (not (memq (car l) symbols)) + (not (null? (cdr l))) + (loop (cddr l) (cons (car l) symbols))))))) + +(define-integrable (procedure-of-arity? object arity) + (and (procedure? object) + (procedure-arity-valid? object arity))) + +(define-integrable (guarantee-symbol object operator) + (if (not (symbol? object)) + (error:wrong-type-argument object "symbol" operator))) + +(define-integrable (guarantee-continuation object operator) + (if (not (continuation? object)) + (error:wrong-type-argument object "continuation" operator))) + +(define-integrable (guarantee-output-port object operator) + (if (not (output-port? object)) + (error:wrong-type-argument object "output port" operator))) + +(define-integrable (guarantee-condition-type object operator) + (if (not (condition-type? object)) + (error:wrong-type-argument object "condition type" operator))) + +(define-integrable (guarantee-condition-types object operator) + (if (not (and (list? object) (for-all? object condition-type?))) + (error:wrong-type-argument object "list of condition types" operator))) + +(define-integrable (guarantee-condition object operator) + (if (not (condition? object)) + (error:wrong-type-argument object "condition" operator))) + +(define-integrable (guarantee-condition-handler object operator) + (if (not (procedure-of-arity? object 1)) + (error:wrong-type-argument object "procedure of one argument" operator))) + +(define-integrable (guarantee-restart object operator) + (if (not (restart? object)) + (error:wrong-type-argument object "restart" operator))) + +(define-integrable (guarantee-restarts object operator) + (if (not (and (list? object) (for-all? object restart?))) + (error:wrong-type-argument object "list of restarts" operator))) \ No newline at end of file diff --git a/v7/src/runtime/gc.scm b/v7/src/runtime/gc.scm index 836a466e9..876aed4c8 100644 --- a/v7/src/runtime/gc.scm +++ b/v7/src/runtime/gc.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.5 1990/07/16 17:12:23 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/gc.scm,v 14.6 1991/02/15 18:05:23 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 @@ -124,11 +124,11 @@ MIT in each case. |# unspecific)))))) (define (default/stack-overflow) - (abort-to-nearest-driver "Aborting!: maximum recursion depth exceeded")) + (abort->nearest "Aborting!: maximum recursion depth exceeded")) (define (default/hardware-trap escape-code) escape-code - (abort-to-nearest-driver "Aborting!: the hardware trapped")) + (abort->nearest "Aborting!: the hardware trapped")) (define pure-space-queue) (define constant-space-queue) @@ -166,7 +166,9 @@ MIT in each case. |# (cmdl-message/standard "Aborting!: out of memory") ;; Clean up whatever possible to avoid a reoccurrence. (cmdl-message/active - (lambda () (with-gc-notification! true gc-clean))))))) + (lambda (cmdl) + cmdl + (with-gc-notification! true gc-clean))))))) ;;;; User Primitives diff --git a/v7/src/runtime/global.scm b/v7/src/runtime/global.scm index 152eeb57a..87cdbe6b5 100644 --- a/v7/src/runtime/global.scm +++ b/v7/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.20 1990/11/14 13:24:16 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/global.scm,v 14.21 1991/02/15 18:05:37 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 @@ -246,20 +246,4 @@ MIT in each case. |# (per-bucket (-1+ index) accumulator) (per-symbol (cdr bucket) - (cons (car bucket) accumulator)))))))) - -(define (error:illegal-datum object #!optional operator-name) - (if (or (default-object? operator-name) (not operator-name)) - (error error-type:wrong-type-argument object) - (error error-type:wrong-type-argument object - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - operator-name))) - -(define (error:datum-out-of-range object #!optional operator-name) - (if (or (default-object? operator-name) (not operator-name)) - (error error-type:bad-range-argument object) - (error error-type:bad-range-argument object - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - operator-name))) \ No newline at end of file + (cons (car bucket) accumulator)))))))) \ No newline at end of file diff --git a/v7/src/runtime/hashtb.scm b/v7/src/runtime/hashtb.scm index 4c0316784..f5c71a3fb 100644 --- a/v7/src/runtime/hashtb.scm +++ b/v7/src/runtime/hashtb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hashtb.scm,v 1.1 1990/02/10 23:43:09 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/hashtb.scm,v 1.2 1991/02/15 18:05:41 cph Exp $ -Copyright (c) 1990 Massachusetts Institute of Technology +Copyright (c) 1990-1 Massachusetts Institute of Technology This material was developed by the Scheme project at the Massachusetts Institute of Technology, Department of Electrical Engineering and @@ -388,7 +388,7 @@ MIT in each case. |# (define (check-arg object predicate default) (cond ((predicate object) object) ((not object) default) - (else (error error-type:wrong-type-argument object)))) + (else (error:wrong-type-datum object false)))) ;;;; Common Hash Table Constructors diff --git a/v7/src/runtime/infstr.scm b/v7/src/runtime/infstr.scm index a61abbcfb..a9925743e 100644 --- a/v7/src/runtime/infstr.scm +++ b/v7/src/runtime/infstr.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.3 1990/01/22 23:41:23 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infstr.scm,v 1.4 1991/02/15 18:05:45 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 @@ -161,35 +161,48 @@ MIT in each case. |# (define (dbg-label/name label) (cond ((dbg-label-2? label) (dbg-label-2/name label)) ((dbg-label-1? label) (dbg-label-1/name label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME)))) (define (set-dbg-label/name! label name) (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/NAME!)))) (define (dbg-label/offset label) (cond ((dbg-label-2? label) (dbg-label-2/offset label)) ((dbg-label-1? label) (dbg-label-1/offset label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/OFFSET)))) (define (dbg-label/external? label) (cond ((dbg-label-2? label) (dbg-label-2/external? label)) ((dbg-label-1? label) (dbg-label-1/external? label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/EXTERNAL?)))) (define (set-dbg-label/external?! label external?) (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?)) ((dbg-label-1? label) (set-dbg-label-1/external?! label external?)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/EXTERNAL?!)))) (define (dbg-label/names label) (cond ((dbg-label-2? label) (dbg-label-2/names label)) ((dbg-label-1? label) (dbg-label-1/names label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/NAMES)))) (define (set-dbg-label/names! label names) (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/NAMES!)))) (define-structure (dbg-label-1 (named diff --git a/v7/src/runtime/infutl.scm b/v7/src/runtime/infutl.scm index 3d62bb11b..a0305baae 100644 --- a/v7/src/runtime/infutl.scm +++ b/v7/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.19 1990/11/15 19:07:18 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/infutl.scm,v 1.20 1991/02/15 18:05:49 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 @@ -90,7 +90,7 @@ MIT in each case. |# (and (file-exists? filename) (call-with-current-continuation (lambda (k) - (bind-condition-handler (list error-type:fasload) + (bind-condition-handler (list condition-type:fasload-band) (lambda (condition) condition (k false)) (lambda () (fasload filename true))))))) diff --git a/v7/src/runtime/input.scm b/v7/src/runtime/input.scm index 6fd79ac76..27539e65f 100644 --- a/v7/src/runtime/input.scm +++ b/v7/src/runtime/input.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.11 1990/11/09 10:10:35 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/input.scm,v 14.12 1991/02/15 18:05:53 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 @@ -63,7 +63,8 @@ MIT in each case. |# (operation-names false read-only true)) (define (guarantee-input-port port) - (if (not (input-port? port)) (error "Bad input port" port)) + (if (not (input-port? port)) + (error:wrong-type-argument port "input port" false)) port) (define (input-port/copy port state) @@ -236,8 +237,9 @@ MIT in each case. |# 0 (begin (if (not (exact-nonnegative-integer? interval)) - (error:illegal-datum interval - 'CHAR-READY?)) + (error:wrong-type-argument interval + false + 'CHAR-READY?)) interval)))) (define (peek-char #!optional port) diff --git a/v7/src/runtime/intrpt.scm b/v7/src/runtime/intrpt.scm index 91d0e9111..d9cce8ebf 100644 --- a/v7/src/runtime/intrpt.scm +++ b/v7/src/runtime/intrpt.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.5 1990/10/02 22:43:13 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/intrpt.scm,v 14.6 1991/02/15 18:05:58 cph Exp $ -Copyright (c) 1988, 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 @@ -104,16 +104,24 @@ MIT in each case. |# (define (suspend-interrupt-handler interrupt-code interrupt-enables) interrupt-code interrupt-enables (clear-interrupts! interrupt-bit/suspend) - (bind-condition-handler '() (lambda (condition) condition (%exit)) + (bind-condition-handler (list condition-type:serious-condition) + (lambda (condition) + condition + (%exit)) (lambda () - (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend") - (home-directory-pathname)) - true)) - (%exit))))) + (bind-condition-handler (list condition-type:warning) + (lambda (condition) + condition + (muffle-warning)) + (lambda () + (if (not (disk-save (merge-pathnames (string->pathname "scheme_suspend") + (home-directory-pathname)) + true)) + (%exit))))))) (define (gc-out-of-space-handler . args) args - (abort-to-nearest-driver "Aborting! Out of memory")) + (abort->nearest "Aborting! Out of memory")) (define (illegal-interrupt-handler interrupt-code interrupt-enables) (error "Illegal interrupt" interrupt-code interrupt-enables)) diff --git a/v7/src/runtime/io.scm b/v7/src/runtime/io.scm index e2a21f187..2fa21d908 100644 --- a/v7/src/runtime/io.scm +++ b/v7/src/runtime/io.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.16 1990/11/14 13:25:29 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/io.scm,v 14.17 1991/02/15 18:06:02 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 @@ -232,17 +232,32 @@ MIT in each case. |# (let ((descriptors ((ucode-primitive channel-table 0)))) (and descriptors (vector-map descriptors descriptor->channel))))))) + +(define (bind-port-for-errors port thunk) + (bind-condition-handler (list condition-type:error) + (lambda (condition) (error:derived-port port condition)) + thunk)) ;;;; File Primitives (define (file-open primitive filename) (let ((channel - (without-interrupts (lambda () (make-channel (primitive filename)))))) + (bind-condition-handler (list condition-type:error) + (lambda (condition) + (error + (make-condition condition-type:open-file-error + (condition/continuation condition) + (condition/restarts condition) + `(FILENAME ,filename)))) + (lambda () + (without-interrupts + (lambda () + (make-channel (primitive filename)))))))) (if (or (channel-type=directory? channel) (channel-type=unknown? channel)) (begin (channel-close channel) - (error:datum-out-of-range filename primitive))) + (error:bad-range-argument filename primitive))) channel)) (define (file-open-input-channel filename) diff --git a/v7/src/runtime/lambda.scm b/v7/src/runtime/lambda.scm index 88c8b7634..28241e489 100644 --- a/v7/src/runtime/lambda.scm +++ b/v7/src/runtime/lambda.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.7 1990/09/11 22:57:30 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/lambda.scm,v 14.8 1991/02/15 18:06:07 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 @@ -421,14 +421,14 @@ MIT in each case. |# ((cond ((slambda? *lambda) clambda-op) ((slexpr? *lambda) clexpr-op) ((xlambda? *lambda) xlambda-op) - (else (error:illegal-datum *lambda op-name))) + (else (error:wrong-type-argument *lambda "SCode lambda" op-name))) *lambda)) (define ((dispatch-1 op-name clambda-op clexpr-op xlambda-op) *lambda arg) ((cond ((slambda? *lambda) clambda-op) ((slexpr? *lambda) clexpr-op) ((xlambda? *lambda) xlambda-op) - (else (error:illegal-datum *lambda op-name))) + (else (error:wrong-type-argument *lambda "SCode lambda" op-name))) *lambda arg)) (define &lambda-components) diff --git a/v7/src/runtime/load.scm b/v7/src/runtime/load.scm index a5ea46220..5d3d058f0 100644 --- a/v7/src/runtime/load.scm +++ b/v7/src/runtime/load.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.19 1990/11/19 19:33:01 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/load.scm,v 14.20 1991/02/15 18:06:13 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 @@ -183,7 +183,7 @@ MIT in each case. |# (load/default-find-pathname-with-type pathname default-types))))) (if (not truename) - (error error-type:open-file pathname)) + (error:open-file pathname)) truename))) (define (search-types-in-order pathname default-types) diff --git a/v7/src/runtime/make.scm b/v7/src/runtime/make.scm index 2b3417147..fee20a906 100644 --- a/v7/src/runtime/make.scm +++ b/v7/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.25 1990/11/15 23:27:03 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/make.scm,v 14.26 1991/02/15 18:06:25 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 @@ -304,6 +304,8 @@ MIT in each case. |# (RUNTIME HASH) (RUNTIME RANDOM-NUMBER) (RUNTIME RECORD) + (RUNTIME ERROR-HANDLER) + (RUNTIME MICROCODE-ERRORS) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME LAMBDA-ABSTRACTION) @@ -340,8 +342,6 @@ MIT in each case. |# (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) ;; REP Loops - (RUNTIME ERROR-HANDLER) - (RUNTIME MICROCODE-ERRORS) (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) (RUNTIME REP) diff --git a/v7/src/runtime/numpar.scm b/v7/src/runtime/numpar.scm index 2786138a6..dac205766 100644 --- a/v7/src/runtime/numpar.scm +++ b/v7/src/runtime/numpar.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.6 1990/09/11 22:33:26 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/numpar.scm,v 14.7 1991/02/15 18:06:30 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 @@ -41,7 +41,7 @@ MIT in each case. |# 10 (begin (if (not (memv radix-default '(2 8 10 16))) - (error:datum-out-of-range radix-default 'STRING->NUMBER)) + (error:bad-range-argument radix-default 'STRING->NUMBER)) radix-default)))) (with-values (lambda () (parse-prefix (string->list string))) (lambda (chars radix-prefix exactness) diff --git a/v7/src/runtime/pathnm.scm b/v7/src/runtime/pathnm.scm index bb5e6d77d..2e03e1f30 100644 --- a/v7/src/runtime/pathnm.scm +++ b/v7/src/runtime/pathnm.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.10 1990/11/15 23:45:39 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/pathnm.scm,v 14.11 1991/02/15 18:06:34 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 @@ -340,7 +340,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (canonicalize-input-pathname filename) (let ((pathname (->pathname filename))) (let ((truename (pathname->input-truename pathname))) - (if (not truename) (error error-type:open-file pathname)) + (if (not truename) (error:open-file pathname)) truename))) (define (pathname->input-truename pathname) @@ -427,7 +427,7 @@ See the files unkpth.scm, vmspth.scm, or unxpth.scm for examples.|# (define (system-library-pathname pathname) (let loop ((directories library-directory-path)) (if (null? directories) - (error error-type:open-file pathname)) + (error:open-file pathname)) (or (pathname->input-truename (merge-pathnames pathname (car directories))) (loop (cdr directories))))) diff --git a/v7/src/runtime/process.scm b/v7/src/runtime/process.scm index dc617c772..90f6a991e 100644 --- a/v7/src/runtime/process.scm +++ b/v7/src/runtime/process.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.4 1990/11/09 08:44:17 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/process.scm,v 1.5 1991/02/15 18:06:38 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 @@ -61,7 +61,8 @@ MIT in each case. |# ((inherited) 1) ((pipe) 2) ((pty) 3) - (else (error:illegal-datum ctty-type 'MAKE-SUBPROCESS)))))) + (else + (error:wrong-type-argument ctty-type false 'MAKE-SUBPROCESS)))))) (let ((input-channel (without-interrupts (lambda () diff --git a/v7/src/runtime/record.scm b/v7/src/runtime/record.scm index 1480502d8..991ab4a87 100644 --- a/v7/src/runtime/record.scm +++ b/v7/src/runtime/record.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.7 1990/10/16 21:03:14 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/record.scm,v 1.8 1991/02/15 18:06:42 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,10 +47,14 @@ MIT in each case. |# (unparser/standard-method type-name)) (named-structure/set-tag-description! record-type (letrec ((description - (let ((predicate (record-predicate record-type))) + (let ((predicate (record-predicate record-type)) + (record-name + (string-append "record of type " + (write-to-string type-name)))) (lambda (record) (if (not (predicate record)) - (error:illegal-datum record description)) + (error:wrong-type-argument record record-name + description)) (map (lambda (field-name) (list field-name (vector-ref @@ -69,12 +73,13 @@ MIT in each case. |# (define (record-type-name record-type) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-TYPE-NAME)) + (error:wrong-type-argument record-type "record type" 'RECORD-TYPE-NAME)) (vector-ref record-type 1)) (define (record-type-field-names record-type) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-TYPE-FIELD-NAMES)) + (error:wrong-type-argument record-type "record type" + 'RECORD-TYPE-FIELD-NAMES)) (list-copy (vector-ref record-type 2))) (define-integrable (record-type-record-length record-type) @@ -83,14 +88,15 @@ MIT in each case. |# (define (record-type-field-index record-type field-name procedure-name) (let loop ((field-names (vector-ref record-type 2)) (index 1)) (if (null? field-names) - (error:datum-out-of-range field-name procedure-name)) + (error:bad-range-argument field-name procedure-name)) (if (eq? field-name (car field-names)) index (loop (cdr field-names) (+ index 1))))) (define (set-record-type-unparser-method! record-type method) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'SET-RECORD-TYPE-UNPARSER-METHOD!)) + (error:wrong-type-argument record-type "record type" + 'SET-RECORD-TYPE-UNPARSER-METHOD!)) (unparser/set-tagged-vector-method! record-type method)) (define record-type-marker) @@ -106,13 +112,14 @@ MIT in each case. |# (named-structure/set-tag-description! record-type-marker (lambda (record-type) (if (not (record-type? record-type)) - (error:illegal-datum record-type false)) + (error:wrong-type-argument record-type "record type" false)) `((TYPE-NAME ,(record-type-name record-type)) (FIELD-NAMES ,(record-type-field-names record-type)))))) (define (record-constructor record-type #!optional field-names) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-CONSTRUCTOR)) + (error:wrong-type-argument record-type "record type" + 'RECORD-CONSTRUCTOR)) (let ((field-names (if (default-object? field-names) (vector-ref record-type 2) @@ -143,12 +150,12 @@ MIT in each case. |# (define (record-type-descriptor record) (if (not (record? record)) - (error:illegal-datum record 'RECORD-TYPE-DESCRIPTOR)) + (error:wrong-type-argument record "record" 'RECORD-TYPE-DESCRIPTOR)) (vector-ref record 0)) (define (record-predicate record-type) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-PREDICATE)) + (error:wrong-type-argument record-type "record type" 'RECORD-PREDICATE)) (let ((record-length (record-type-record-length record-type))) (lambda (object) (and (vector? object) @@ -157,7 +164,7 @@ MIT in each case. |# (define (record-accessor record-type field-name) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-ACCESSOR)) + (error:wrong-type-argument record-type "record type" 'RECORD-ACCESSOR)) (let ((record-length (record-type-record-length record-type)) (procedure-name `(RECORD-ACCESSOR ,record-type ',field-name)) (index @@ -166,12 +173,12 @@ MIT in each case. |# (if (not (and (vector? record) (= (vector-length record) record-length) (eq? (vector-ref record 0) record-type))) - (error:illegal-datum record procedure-name)) + (error:wrong-type-argument record "record" procedure-name)) (vector-ref record index)))) (define (record-updater record-type field-name) (if (not (record-type? record-type)) - (error:illegal-datum record-type 'RECORD-UPDATER)) + (error:wrong-type-argument record-type "record type" 'RECORD-UPDATER)) (let ((record-length (record-type-record-length record-type)) (procedure-name `(RECORD-UPDATER ,record-type ',field-name)) (index @@ -180,5 +187,5 @@ MIT in each case. |# (if (not (and (vector? record) (= (vector-length record) record-length) (eq? (vector-ref record 0) record-type))) - (error:illegal-datum record procedure-name)) + (error:wrong-type-argument record "record" procedure-name)) (vector-set! record index field-value)))) \ No newline at end of file diff --git a/v7/src/runtime/rep.scm b/v7/src/runtime/rep.scm index c6564b1fd..891400879 100644 --- a/v7/src/runtime/rep.scm +++ b/v7/src/runtime/rep.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.16 1990/11/15 15:42:20 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/rep.scm,v 14.17 1991/02/15 18:06:46 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 @@ -45,10 +45,7 @@ MIT in each case. |# (object-component-binder cmdl/output-port set-cmdl/output-port!)) (set! hook/cmdl-prompt default/cmdl-prompt) (set! hook/cmdl-message default/cmdl-message) - (set! cmdl-interrupt/breakpoint default/breakpoint) - (set! cmdl-interrupt/abort-top-level default/abort-top-level) - (set! cmdl-interrupt/abort-previous default/abort-previous) - (set! cmdl-interrupt/abort-nearest default/abort-nearest) + (set! hook/error-decision false) (set! hook/repl-environment default/repl-environment) (set! hook/repl-read default/repl-read) (set! hook/repl-write default/repl-write) @@ -59,21 +56,16 @@ MIT in each case. |# unspecific) (define (initial-top-level-repl) - (fluid-let ((user-repl-environment user-initial-environment) - (user-repl-syntax-table user-initial-syntax-table)) - (let loop ((message "Cold load finished")) - (with-standard-proceed-point - (lambda () - (make-cmdl false - console-input-port - console-output-port - repl-driver - (make-repl-state user-initial-prompt - user-repl-environment - user-repl-syntax-table) - (cmdl-message/standard message) - make-cmdl))) - (loop "Reset!")))) + (make-cmdl false + console-input-port + console-output-port + repl-driver + (make-repl-state user-initial-prompt + user-initial-environment + user-initial-syntax-table + false) + (cmdl-message/standard "Cold load finished") + make-cmdl)) ;;;; Command Loops @@ -81,46 +73,42 @@ MIT in each case. |# (parent false read-only true) (level false read-only true) (driver false read-only true) - (proceed-continuation false read-only true) (spawn-child false read-only true) - continuation input-port output-port state) (define (make-cmdl parent input-port output-port driver state message spawn-child) - (if (and parent (not (cmdl? parent))) - (error:illegal-datum parent 'MAKE-CMDL)) - (let ((cmdl - (%make-cmdl parent - (let loop ((parent parent)) - (if parent - (+ (loop (cmdl/parent parent)) 1) - 1)) - driver - (current-proceed-continuation) - spawn-child - false - input-port - output-port - state))) - (let loop ((message message)) - (loop - (fluid-let - ((*nearest-cmdl* cmdl) - (cmdl-interrupt/abort-nearest default/abort-nearest) - (cmdl-interrupt/abort-previous default/abort-previous) - (cmdl-interrupt/abort-top-level default/abort-top-level) - (cmdl-interrupt/breakpoint default/breakpoint)) - (with-interrupt-mask interrupt-mask/all - (lambda (interrupt-mask) - interrupt-mask - (call-with-current-continuation - (lambda (continuation) - (set-cmdl/continuation! cmdl continuation) - (message cmdl) - (driver cmdl)))))))))) + (if (not (or (false? parent) (cmdl? parent))) + (error:wrong-type-argument parent "cmdl or #f" 'MAKE-CMDL)) + (let ((level (if parent (+ (cmdl/level parent) 1) 1))) + (let ((cmdl + (%make-cmdl parent level driver spawn-child input-port output-port + state))) + (let loop ((message message)) + (loop + (call-with-current-continuation + (lambda (continuation) + (bind-restart 'ABORT + (string-append "Return to " + (if (repl? cmdl) "read-eval-print" "command") + " level " + (number->string level) + ".") + (lambda (#!optional message) + (continuation + (if (default-object? message) + (cmdl-message/standard "Abort!") + message))) + (lambda (restart) + (restart/put! restart make-cmdl cmdl) + (fluid-let ((*nearest-cmdl* cmdl)) + (with-interrupt-mask interrupt-mask/all + (lambda (interrupt-mask) + interrupt-mask + (message cmdl) + ((cmdl/driver cmdl) cmdl))))))))))))) (define *nearest-cmdl*) @@ -128,6 +116,12 @@ MIT in each case. |# (if (not *nearest-cmdl*) (error "NEAREST-CMDL: no cmdl")) *nearest-cmdl*) +(define (nearest-cmdl/input-port) + (cmdl/input-port (nearest-cmdl))) + +(define (nearest-cmdl/output-port) + (cmdl/output-port (nearest-cmdl))) + (define (push-cmdl driver state message spawn-child) (let ((parent (nearest-cmdl))) ((cmdl/spawn-child parent) parent @@ -150,7 +144,6 @@ MIT in each case. |# ;;;; Messages (define hook/cmdl-prompt) - (define (default/cmdl-prompt cmdl prompt) (with-output-port-cooked cmdl (lambda (output-port) @@ -166,7 +159,6 @@ MIT in each case. |# (hook/cmdl-message cmdl string)) (define hook/cmdl-message) - (define (default/cmdl-message cmdl string) (with-output-port-cooked cmdl (lambda (output-port) @@ -179,120 +171,153 @@ MIT in each case. |# (write-string (string-append "\n" string) output-port)) strings)))) -(define ((cmdl-message/null) cmdl) - cmdl - false) - -(define ((cmdl-message/active thunk) cmdl) +(define ((cmdl-message/active actor) cmdl) (with-output-port-cooked cmdl (lambda (output-port) - (with-output-to-port output-port thunk)))) - -(define ((cmdl-message/append . messages) cmdl) - (for-each (lambda (message) (message cmdl)) messages)) + (with-output-to-port output-port + (lambda () + (actor cmdl)))))) + +(define (cmdl-message/append . messages) + (let ((messages (delq! %cmdl-message/null messages))) + (cond ((null? messages) + (cmdl-message/null)) + ((null? (cdr messages)) + (car messages)) + (else + (lambda (cmdl) + (for-each (lambda (message) (message cmdl)) messages)))))) + +(define-integrable (cmdl-message/null) + %cmdl-message/null) + +(define (%cmdl-message/null cmdl) + cmdl + false) ;;;; Interrupts -(define cmdl-interrupt/abort-nearest) -(define cmdl-interrupt/abort-previous) -(define cmdl-interrupt/abort-top-level) -(define cmdl-interrupt/breakpoint) +(define (cmdl-interrupt/abort-nearest) + (abort->nearest "Abort!")) -(define (default/abort-nearest) - (abort-to-nearest-driver "Abort!")) +(define (cmdl-interrupt/abort-previous) + (abort->previous "Up!")) -(define (abort-to-nearest-driver message) - (abort->nearest (cmdl-message/standard message))) +(define (cmdl-interrupt/abort-top-level) + (abort->top-level "Quit!")) (define (abort->nearest message) - ((cmdl/continuation (nearest-cmdl)) message)) - -(define (default/abort-previous) - (abort-to-previous-driver "Up!")) - -(define (abort-to-previous-driver message) - (abort->previous (cmdl-message/standard message))) + (invoke-abort (let ((restart (find-restart 'ABORT))) + (if (not restart) + (error:no-such-restart 'ABORT)) + restart) + message)) (define (abort->previous message) - ((cmdl/continuation - (let ((cmdl (nearest-cmdl))) - (or (cmdl/parent cmdl) - cmdl))) - message)) - -(define (default/abort-top-level) - (abort-to-top-level-driver "Quit!")) - -(define (abort-to-top-level-driver message) - (abort->top-level (cmdl-message/standard message))) + (invoke-abort (let ((restarts (find-restarts 'ABORT (bound-restarts)))) + (let ((next (find-restarts 'ABORT (cdr restarts)))) + (cond ((not (null? next)) (car next)) + ((not (null? restarts)) (car restarts)) + (else (error:no-such-restart 'ABORT))))) + message)) (define (abort->top-level message) - ((let ((cmdl (cmdl/base (nearest-cmdl)))) - (if cmdl-interrupt/abort-top-level/reset? - (cmdl/proceed-continuation cmdl) - (cmdl/continuation cmdl))) - message)) - -;; User option variable -(define cmdl-interrupt/abort-top-level/reset? false) - -(define (default/breakpoint) - (with-standard-proceed-point - (lambda () - (breakpoint (cmdl-message/standard "^B interrupt") - (nearest-repl/environment))))) - -;;;; Proceed - -(define (with-proceed-point value-filter thunk) - (call-with-current-continuation - (lambda (continuation) - (fluid-let ((proceed-continuation continuation) - (proceed-value-filter value-filter)) - (thunk))))) - -(define (current-proceed-continuation) - proceed-continuation) - -(define (proceed . arguments) - (proceed-value-filter proceed-continuation arguments)) - -(define proceed-continuation false) -(define proceed-value-filter) - -(define (with-standard-proceed-point thunk) - (with-proceed-point standard-value-filter thunk)) - -(define (standard-value-filter continuation arguments) - (continuation - (if (null? arguments) - unspecific - (car arguments)))) + (invoke-abort (let loop ((restarts (find-restarts 'ABORT (bound-restarts)))) + (let ((next (find-restarts 'ABORT (cdr restarts)))) + (cond ((not (null? next)) (loop next)) + ((not (null? restarts)) (car restarts)) + (else (error:no-such-restart 'ABORT))))) + message)) + +(define (find-restarts name restarts) + (let loop ((restarts restarts)) + (if (or (null? restarts) + (eq? name (restart/name (car restarts)))) + restarts + (loop (cdr restarts))))) + +(define (invoke-abort restart message) + (let ((effector (restart/effector restart))) + (if (restart/get restart make-cmdl) + (effector + (if (string? message) (cmdl-message/standard message) message)) + (effector)))) + +(define (cmdl-interrupt/breakpoint) + (with-simple-restart 'CONTINUE "Continue from ^B interrupt." + (lambda () + (push-repl "^B interrupt" false "^B>")))) ;;;; REP Loops (define-structure (repl-state (conc-name repl-state/) (constructor make-repl-state - (prompt environment syntax-table))) + (prompt environment syntax-table condition))) prompt environment syntax-table + (condition false read-only true) (reader-history (make-repl-history reader-history-size)) (printer-history (make-repl-history printer-history-size))) -(define (push-repl environment message prompt) - (push-cmdl repl-driver - (make-repl-state prompt environment (nearest-repl/syntax-table)) - (cmdl-message/append - message - (cmdl-message/active - (lambda () - (hook/repl-environment (nearest-repl) environment)))) - make-cmdl)) +(define (push-repl message condition + #!optional prompt environment syntax-table) + (let ((environment (if (default-object? environment) 'INHERIT environment))) + (push-cmdl repl-driver + (let ((repl (nearest-repl))) + (make-repl-state (if (or (default-object? prompt) + (eq? 'INHERIT prompt)) + (repl/prompt repl) + prompt) + (if (eq? 'INHERIT environment) + (repl/environment repl) + environment) + (if (or (default-object? syntax-table) + (eq? 'INHERIT syntax-table)) + (repl/syntax-table repl) + syntax-table) + condition)) + (cmdl-message/append + (cond ((not message) + (if condition + (cmdl-message/strings + (with-string-output-port + (lambda (port) + (write-string ";" port) + (write-condition-report condition + port)))) + (cmdl-message/null))) + ((string? message) + (cmdl-message/standard message)) + (else + message)) + (if condition + (cmdl-message/append + (if hook/error-decision + (cmdl-message/active + (lambda (cmdl) + cmdl + (hook/error-decision))) + (cmdl-message/null)) + (condition-restarts-message condition)) + (cmdl-message/null)) + (if (eq? 'INHERIT environment) + (cmdl-message/null) + (cmdl-message/active + (lambda (cmdl) + cmdl + (repl-environment (nearest-repl) environment))))) + (lambda args + (with-history-disabled + (lambda () + (apply make-cmdl args))))))) + +(define hook/error-decision) (define (repl-driver repl) - (fluid-let ((hook/error-handler default/error-handler)) + (fluid-let ((standard-error-hook false) + (standard-warning-hook false)) (hook/cmdl-prompt repl (repl/prompt repl)) (let ((s-expression (hook/repl-read repl))) (cmdl-message/value @@ -300,7 +325,85 @@ MIT in each case. |# s-expression (repl/environment repl) (repl/syntax-table repl)))))) - + +(define (condition-restarts-message condition) + (cmdl-message/active + (lambda (cmdl) + (let ((port (cmdl/output-port cmdl))) + (write-string " +;To continue, call RESTART with an option number:" port) + (write-restarts (filter-restarts (condition/restarts condition)) port + (lambda (index port) + (write-string " (RESTART " port) + (write index port) + (write-string ") =>" port))))))) + +(define (restart #!optional n) + (let ((restarts + (filter-restarts + (let ((condition (nearest-repl/condition))) + (if condition + (condition/restarts condition) + (bound-restarts)))))) + (let ((n-restarts (length restarts))) + (if (zero? n-restarts) + (error "Can't RESTART: no options available.")) + (invoke-restart-interactively + (list-ref + restarts + (- n-restarts + (if (default-object? n) + (let ((port (nearest-cmdl/output-port))) + (newline port) + (write-string ";Choose an option by number:" port) + (write-restarts restarts port + (lambda (index port) + (write-string (string-pad-left (number->string index) 3) + port) + (write-string ":" port))) + (let loop () + (let ((n + (prompt-for-evaluated-expression "Option number"))) + (if (and (exact-integer? n) (<= 1 n n-restarts)) + n + (begin + (beep port) + (newline port) + (write-string + ";Option must be an integer between 1 and " + port) + (write n-restarts port) + (write-string ", inclusive.") + (loop)))))) + (begin + (if (not (exact-integer? n)) + (error:wrong-type-argument n "exact integer" 'RESTART)) + (if (not (<= 1 n n-restarts)) + (error:bad-range-argument n 'RESTART)) + n)))))))) + +(define (write-restarts restarts port write-index) + (newline port) + (do ((restarts restarts (cdr restarts)) + (index (length restarts) (- index 1))) + ((null? restarts)) + (write-string ";" port) + (write-index index port) + (write-string " " port) + (write-restart-report (car restarts) port) + (newline port))) + +(define (filter-restarts restarts) + (let loop ((restarts restarts)) + (if (null? restarts) + '() + (cons (car restarts) + (if (restart/get (car restarts) make-cmdl) + (list-transform-positive (cdr restarts) + (lambda (restart) + (restart/get restart make-cmdl))) + (loop (cdr restarts))))))) + (define (repl? object) (and (cmdl? object) (repl-state? (cmdl/state object)))) @@ -314,8 +417,9 @@ MIT in each case. |# (define-integrable (repl/environment repl) (repl-state/environment (cmdl/state repl))) -(define-integrable (set-repl/environment! repl environment) - (set-repl-state/environment! (cmdl/state repl) environment)) +(define (set-repl/environment! repl environment) + (set-repl-state/environment! (cmdl/state repl) environment) + (repl-environment repl environment)) (define-integrable (repl/syntax-table repl) (repl-state/syntax-table (cmdl/state repl))) @@ -323,6 +427,9 @@ MIT in each case. |# (define-integrable (set-repl/syntax-table! repl syntax-table) (set-repl-state/syntax-table! (cmdl/state repl) syntax-table)) +(define-integrable (repl/condition repl) + (repl-state/condition (cmdl/state repl))) + (define-integrable (repl/reader-history repl) (repl-state/reader-history (cmdl/state repl))) @@ -334,7 +441,7 @@ MIT in each case. |# (define-integrable (set-repl/printer-history! repl printer-history) (set-repl-state/printer-history! (cmdl/state repl) printer-history)) - + (define (repl/parent repl) (skip-non-repls (cmdl/parent repl))) @@ -355,32 +462,13 @@ MIT in each case. |# repl))) (define (nearest-repl/environment) - (let ((repl (nearest-repl))) - (if repl - (repl/environment repl) - user-initial-environment))) + (repl/environment (nearest-repl))) (define (nearest-repl/syntax-table) - (let ((repl (nearest-repl))) - (if repl - (repl/syntax-table repl) - user-initial-syntax-table))) - -(define (read-eval-print environment message prompt) - (with-standard-proceed-point - (lambda () - (push-repl environment message prompt)))) + (repl/syntax-table (nearest-repl))) -(define (breakpoint message environment) - (push-repl environment message "Bkpt->")) - -(define (breakpoint-procedure environment message . irritants) - (with-history-disabled - (lambda () - (with-standard-proceed-point - (lambda () - (breakpoint (apply cmdl-message/error message irritants) - environment)))))) +(define (nearest-repl/condition) + (repl/condition (nearest-repl))) ;;;; Hooks @@ -389,6 +477,12 @@ MIT in each case. |# (define hook/repl-eval) (define hook/repl-write) +(define (repl-environment repl environment) + (with-output-port-cooked repl + (lambda (output-port) + output-port + (hook/repl-environment repl environment)))) + (define (default/repl-environment repl environment) (let ((port (cmdl/output-port repl))) (if (not (interpreter-environment? environment)) @@ -401,8 +495,7 @@ MIT in each case. |# (if package (begin (write-string "\n;Package: " port) - (write (package/name package) port))))) - unspecific) + (write (package/name package) port)))))) (define (default/repl-read repl) (let ((s-expression (read-internal (cmdl/input-port repl)))) @@ -424,7 +517,12 @@ MIT in each case. |# (if (undefined-value? object) (write-string "\n;No value" output-port) (begin - (write-string "\n;Value: " output-port) + (write-string "\n;Value" output-port) + (if (object-pointer? object) + (begin + (write-string " " output-port) + (write (object-hash object) output-port))) + (write-string ": " output-port) (write object output-port)))))) ;;;; History @@ -456,15 +554,12 @@ MIT in each case. |# (define (repl-history/read history n) (if (not (and (exact-nonnegative-integer? n) (< n (repl-history/size history)))) - (error:illegal-datum n 'REPL-HISTORY/READ)) + (error:wrong-type-argument n "history index" 'REPL-HISTORY/READ)) (list-ref (repl-history/elements history) (- (- (repl-history/size history) 1) n))) ;;; User Interface Stuff -(define user-repl-environment) -(define user-repl-syntax-table) - (define (pe) (let ((environment (nearest-repl/environment))) (let ((package (environment->package environment))) @@ -473,15 +568,8 @@ MIT in each case. |# environment)))) (define (ge environment) - (let ((repl (nearest-repl)) - (environment (->environment environment))) - (set-repl-state/environment! (cmdl/state repl) environment) - (if (not (cmdl/parent repl)) - (set! user-repl-environment environment)) - (with-output-port-cooked repl - (lambda (output-port) - output-port - (hook/repl-environment repl environment))) + (let ((environment (->environment environment))) + (set-repl/environment! (nearest-repl) environment) environment)) (define (->environment object) @@ -498,15 +586,12 @@ MIT in each case. |# (and package-name (name->package package-name))))) (if (not package) - (error:illegal-datum object '->ENVIRONMENT)) + (error:wrong-type-argument object "environment" '->ENVIRONMENT)) (package/environment package))))) (define (gst syntax-table) (guarantee-syntax-table syntax-table) - (let ((repl (nearest-repl))) - (set-repl-state/syntax-table! (cmdl/state repl) syntax-table) - (if (not (cmdl/parent repl)) - (set! user-repl-syntax-table syntax-table))) + (set-repl-state/syntax-table! (cmdl/state (nearest-repl)) syntax-table) unspecific) (define (re #!optional index) @@ -531,6 +616,38 @@ MIT in each case. |# (repl-history/read (repl/printer-history (nearest-repl)) (- (if (default-object? index) 1 index) 1))) +(define (read-eval-print environment message prompt) + (push-repl message false prompt environment)) + +(define (breakpoint message environment) + (with-simple-restart 'CONTINUE "Continue from breakpoint." + (lambda () + (read-eval-print environment message "Breakpoint->")))) + +(define (bkpt datum . arguments) + (apply breakpoint-procedure 'INHERIT datum arguments)) + +(define (breakpoint-procedure environment datum . arguments) + ;; For upwards compatibility. + (with-simple-restart 'CONTINUE "Return from BKPT." + (lambda () + (read-eval-print environment + (cmdl-message/active + (lambda (cmdl) + (let ((port (cmdl/output-port cmdl))) + (newline port) + (format-error-message datum arguments port)))) + "Bkpt->")))) + +(define (ve environment) + (read-eval-print (->environment environment) false 'INHERIT)) + +(define (proceed #!optional value) + (if (default-object? value) + (continue) + (use-value value)) + (write-string "\n;Unable to PROCEED" (nearest-cmdl/output-port))) + ;;;; Prompting (define (prompt-for-command-char prompt #!optional cmdl) @@ -546,6 +663,18 @@ MIT in each case. |# (hook/prompt-for-expression (if (default-object? cmdl) (nearest-cmdl) cmdl) prompt)) +(define (prompt-for-evaluated-expression prompt #!optional + environment syntax-table) + (let ((repl (nearest-repl))) + (hook/repl-eval repl + (prompt-for-expression prompt) + (if (default-object? environment) + (repl/environment repl) + environment) + (if (default-object? syntax-table) + (repl/syntax-table repl) + syntax-table)))) + (define hook/read-command-char) (define hook/prompt-for-confirmation) (define hook/prompt-for-expression) diff --git a/v7/src/runtime/runtime.pkg b/v7/src/runtime/runtime.pkg index 2373ecc3b..40e8bf27d 100644 --- a/v7/src/runtime/runtime.pkg +++ b/v7/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.88 1991/01/26 03:23:44 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/runtime.pkg,v 14.89 1991/02/15 18:06:51 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -527,53 +527,97 @@ MIT in each case. |# (files "error") (parent ()) (export () + abort + access-condition bind-condition-handler - cmdl-message/error - condition-type/generalizations + bind-restart + bound-restarts + break-on-signals + condition-accessor + condition-constructor + condition-predicate + condition-signaller condition-type/error? + condition-type/field-names + condition-type/generalizations + condition-type/get condition-type/properties - condition-type/reporter + condition-type/put! + condition-type:arithmetic-error + condition-type:bad-range-argument + condition-type:cell-error + condition-type:control-error + condition-type:datum-out-of-range + condition-type:derived-port-error + condition-type:divide-by-zero condition-type:error + condition-type:file-error + condition-type:file-touch-error + condition-type:floating-point-overflow + condition-type:floating-point-underflow + condition-type:illegal-datum + condition-type:no-such-restart + condition-type:open-file-error + condition-type:port-error + condition-type:serious-condition + condition-type:simple-condition + condition-type:simple-error + condition-type:simple-warning + condition-type:unassigned-variable + condition-type:unbound-variable + condition-type:variable-error + condition-type:warning + condition-type:wrong-number-of-arguments + condition-type:wrong-type-argument + condition-type:wrong-type-datum condition-type? condition/continuation condition/error? - condition/generalizations - condition/internal? - condition/irritants - condition/message + condition/get condition/properties - condition/report-string - condition/reporter + condition/put! + condition/restarts condition/type - condition/write-report condition? - error-condition - error-continuation - error-irritant + continue + error error-irritant/noise - error-irritant/noise-value - error-irritant/noise? - error-irritants - error-irritants/sans-noise - error-message - error-type:vanilla - error-type? - error? + error:bad-range-argument + error:datum-out-of-range + error:derived-port + error:divide-by-zero + error:file-touch + error:no-such-restart + error:open-file + error:wrong-number-of-arguments + error:wrong-type-argument + error:wrong-type-datum + find-restart format-error-message - guarantee-condition - guarantee-condition-type + invoke-restart + invoke-restart-interactively make-condition make-condition-type - make-error-type + muffle-warning + restart/effector + restart/get + restart/name + restart/properties + restart/put! + restart? signal-condition - signal-error standard-error-handler - warn) - (export (runtime rep) - default/error-handler - hook/error-handler) - (export (runtime emacs-interface) - hook/error-decision) + standard-error-hook + standard-warning-handler + standard-warning-hook + store-value + use-value + warn + with-simple-restart + write-condition-report + write-restart-report) + (export (runtime microcode-errors) + write-operator) (initialization (initialize-package!))) (define-package (runtime event-distributor) @@ -1062,18 +1106,27 @@ MIT in each case. |# (files "uerror") (parent (runtime error-handler)) (export () - error-type:anomalous - error-type:bad-range-argument - error-type:failed-argument-coercion - error-type:fasdump - error-type:fasload - error-type:file - error-type:illegal-argument - error-type:open-file - error-type:premature-write-termination - error-type:random-internal - error-type:wrong-type-argument - microcode-error-type) + condition-type:anomalous-microcode-error + condition-type:compiled-code-error + condition-type:fasdump-environment + condition-type:fasl-file-bad-data + condition-type:fasl-file-compiled-mismatch + condition-type:fasl-file-too-big + condition-type:fasload-band + condition-type:fasload-error + condition-type:hardware-trap + condition-type:impurify-object-too-large + condition-type:inapplicable-object + condition-type:microcode-asynchronous + condition-type:out-of-file-handles + condition-type:primitive-io-error + condition-type:primitive-procedure-error + condition-type:system-call-error + condition-type:unimplemented-primitive + condition-type:unimplemented-primitive-for-os + condition-type:unlinkable-variable + condition-type:user-microcode-reset + condition-type:wrong-arity-primitives) (initialization (initialize-package!))) (define-package (runtime microcode-tables) @@ -1422,6 +1475,7 @@ MIT in each case. |# pty-master-send-signal pty-master-stop) (export (runtime generic-input) + bind-port-for-errors input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1438,6 +1492,7 @@ MIT in each case. |# input-buffer/size make-input-buffer) (export (runtime generic-output) + bind-port-for-errors make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1447,6 +1502,7 @@ MIT in each case. |# output-buffer/size output-buffer/write-string-block) (export (runtime file-input) + bind-port-for-errors file-length file-open-input-channel input-buffer/chars-remaining @@ -1457,6 +1513,7 @@ MIT in each case. |# file-open-output-channel make-output-buffer) (export (runtime console-input) + bind-port-for-errors channel-type=file? input-buffer/buffer-contents input-buffer/buffered-chars @@ -1471,6 +1528,7 @@ MIT in each case. |# make-input-buffer tty-input-channel) (export (runtime console-output) + bind-port-for-errors make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1542,15 +1600,12 @@ MIT in each case. |# abort->nearest abort->previous abort->top-level - abort-to-nearest-driver - abort-to-previous-driver - abort-to-top-level-driver + bkpt breakpoint breakpoint-procedure cmdl-interrupt/abort-nearest cmdl-interrupt/abort-previous cmdl-interrupt/abort-top-level - cmdl-interrupt/abort-top-level/reset? cmdl-interrupt/breakpoint cmdl-message/active cmdl-message/append @@ -1559,23 +1614,23 @@ MIT in each case. |# cmdl-message/strings cmdl-message/value cmdl/base - cmdl/continuation cmdl/driver cmdl/input-port cmdl/level cmdl/output-port cmdl/parent - cmdl/proceed-continuation cmdl/state cmdl? - current-proceed-continuation ge gst in initial-top-level-repl make-cmdl nearest-cmdl + nearest-cmdl/input-port + nearest-cmdl/output-port nearest-repl + nearest-repl/condition nearest-repl/environment nearest-repl/syntax-table out @@ -1584,6 +1639,7 @@ MIT in each case. |# prompt-for-command-char prompt-for-confirmation prompt-for-expression + prompt-for-evaluated-expression push-cmdl push-repl re @@ -1599,7 +1655,7 @@ MIT in each case. |# repl/reader-history repl/syntax-table repl? - set-cmdl/continuation! + restart set-cmdl/input-port! set-cmdl/output-port! set-cmdl/state! @@ -1608,16 +1664,16 @@ MIT in each case. |# set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! + ve with-cmdl/input-port - with-cmdl/output-port - with-proceed-point - with-standard-proceed-point) + with-cmdl/output-port) (export (runtime load) hook/repl-eval hook/repl-write) (export (runtime emacs-interface) hook/cmdl-message hook/cmdl-prompt + hook/error-decision hook/prompt-for-confirmation hook/prompt-for-expression hook/read-command-char @@ -1675,6 +1731,7 @@ MIT in each case. |# in-package-expression in-package? intern + interned-symbol? make-absolute-reference make-access make-assignment @@ -1702,6 +1759,7 @@ MIT in each case. |# symbol-hash-mod symbol? the-environment? + uninterned-symbol? variable-components variable-name variable?) diff --git a/v7/src/runtime/scode.scm b/v7/src/runtime/scode.scm index 420de4f61..162e14ee4 100644 --- a/v7/src/runtime/scode.scm +++ b/v7/src/runtime/scode.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.10 1990/09/11 22:57:46 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scode.scm,v 14.11 1991/02/15 18:06:58 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 @@ -99,12 +99,18 @@ MIT in each case. |# ;;;; Symbol (define (symbol? object) - (or (object-type? (ucode-type interned-symbol) object) - (object-type? (ucode-type uninterned-symbol) object))) + (or (interned-symbol? object) + (uninterned-symbol? object))) + +(define-integrable (interned-symbol? object) + (object-type? (ucode-type interned-symbol) object)) + +(define-integrable (uninterned-symbol? object) + (object-type? (ucode-type uninterned-symbol) object)) (define (string->uninterned-symbol string) (if (not (string? string)) - (error:illegal-datum string 'STRING->UNINTERNED-SYMBOL)) + (error:wrong-type-argument string "string" 'STRING->UNINTERNED-SYMBOL)) (&typed-pair-cons (ucode-type uninterned-symbol) string (make-unbound-reference-trap))) @@ -117,7 +123,7 @@ MIT in each case. |# (define (symbol-name symbol) (if (not (symbol? symbol)) - (error:illegal-datum symbol 'SYMBOL-NAME)) + (error:wrong-type-argument symbol "symbol" 'SYMBOL-NAME)) (system-pair-car symbol)) (define-integrable (symbol->string symbol) diff --git a/v7/src/runtime/scomb.scm b/v7/src/runtime/scomb.scm index aff62ef68..19360f46a 100644 --- a/v7/src/runtime/scomb.scm +++ b/v7/src/runtime/scomb.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.9 1990/09/11 22:57:55 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/scomb.scm,v 14.10 1991/02/15 18:07:03 cph Exp $ -Copyright (c) 1988, 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 @@ -170,7 +170,8 @@ MIT in each case. |# (&triple-second expression) (&triple-third expression))) (else - (error:illegal-datum expression 'SEQUENCE-IMMEDIATE-ACTIONS)))) + (error:wrong-type-argument expression "SCode sequence" + 'SEQUENCE-IMMEDIATE-ACTIONS)))) (define-integrable (sequence-components expression receiver) (receiver (sequence-actions expression))) @@ -309,7 +310,8 @@ MIT in each case. |# ,combination)) ,case-n) (ELSE - (ERROR:ILLEGAL-DATUM ,combination ',name)))))) + (ERROR:WRONG-TYPE-ARGUMENT ,combination "SCode combination" + ',name)))))) (define (combination-size combination) (combination-dispatch combination-size combination diff --git a/v7/src/runtime/syntax.scm b/v7/src/runtime/syntax.scm index f4a35daee..829347231 100644 --- a/v7/src/runtime/syntax.scm +++ b/v7/src/runtime/syntax.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.13 1990/09/11 20:45:14 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/Attic/syntax.scm,v 14.14 1991/02/15 18:07:07 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 @@ -170,16 +170,14 @@ MIT in each case. |# (apply transform (cdr expression)))) (define (syntax-error message . irritants) - (error-procedure - (string-append "SYNTAX: " - (if *current-keyword* - (string-append (symbol->string *current-keyword*) - ": " - message) - message)) - irritants - ;; This is not really the right environment. Perhaps nothing is. - syntaxer/default-environment)) + (apply error + (string-append "SYNTAX: " + (if *current-keyword* + (string-append (symbol->string *current-keyword*) + ": " + message) + message)) + irritants)) (define (syntax-expressions expressions) (if (null? expressions) diff --git a/v7/src/runtime/uerror.scm b/v7/src/runtime/uerror.scm index 00533039f..dde89cf80 100644 --- a/v7/src/runtime/uerror.scm +++ b/v7/src/runtime/uerror.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.17 1991/01/26 03:23:51 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/uerror.scm,v 14.18 1991/02/15 18:07:21 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -37,613 +37,864 @@ MIT in each case. |# (declare (usual-integrations)) -(define (initialize-package!) - (set! internal-apply-frame/fasload? - (internal-apply-frame/operator-filter - (ucode-primitive binary-fasload) - (ucode-primitive load-band))) - (set! internal-apply-frame/fasdump? - (internal-apply-frame/operator-filter - (ucode-primitive primitive-fasdump))) - (build-condition-types!) - (set! microcode-error-types (make-error-types)) - (set! error-type:bad-error-code (microcode-error-type 'BAD-ERROR-CODE)) - (let ((fixed-objects (get-fixed-objects-vector))) - (vector-set! fixed-objects - (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) - (make-error-handlers)) - ((ucode-primitive set-fixed-objects-vector!) fixed-objects)) - unspecific) +(define condition-type:anomalous-microcode-error) +(define condition-type:compiled-code-error) +(define condition-type:fasdump-environment) +(define condition-type:fasl-file-bad-data) +(define condition-type:fasl-file-compiled-mismatch) +(define condition-type:fasl-file-too-big) +(define condition-type:fasload-band) +(define condition-type:fasload-error) +(define condition-type:hardware-trap) +(define condition-type:impurify-object-too-large) +(define condition-type:inapplicable-object) +(define condition-type:microcode-asynchronous) +(define condition-type:out-of-file-handles) +(define condition-type:primitive-io-error) +(define condition-type:primitive-procedure-error) +(define condition-type:system-call-error) +(define condition-type:unimplemented-primitive) +(define condition-type:unimplemented-primitive-for-os) +(define condition-type:unlinkable-variable) +(define condition-type:user-microcode-reset) +(define condition-type:wrong-arity-primitives) + +(define error-handler-vector) +(define default-error-handler) + +(define (define-error-handler error-name handler) + (vector-set! error-handler-vector + (microcode-error/name->code error-name) + (lambda (error-code interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (call-with-current-continuation + (lambda (continuation) + (handler continuation) + (default-error-handler continuation error-code)))))) + +(define (define-low-level-handler error-name handler) + (vector-set! error-handler-vector + (microcode-error/name->code error-name) + (lambda (error-code interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (call-with-current-continuation + (lambda (continuation) + (handler continuation error-code) + (default-error-handler continuation error-code)))))) + +(define (condition-signaller type field-names) + (let ((make-condition (condition-constructor type field-names))) + (lambda (continuation . field-values) + (error (apply make-condition + continuation + 'BOUND-RESTARTS + field-values))))) -(define (make-error-handlers) - (let ((error-code-limit (microcode-error/code-limit))) - (let ((alists (make-error-alists error-code-limit))) - (make-initialized-vector error-code-limit - (lambda (index) - (let ((alist (vector-ref alists index))) - (if (procedure? alist) - alist - (let ((error-type (vector-ref microcode-error-types index))) - (if error-type - (make-error-translator alist error-type) - anomalous-microcode-error))))))))) - -(define (make-error-translator alist error-type) - (lambda (error-code interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (with-proceed-point proceed-value-filter - (lambda () - (signal-error - (let ((frame - (continuation/first-subproblem - (current-proceed-continuation)))) - (let ((translator - (let ((return-code (stack-frame/return-code frame))) - (and return-code - (let ((entry (assv return-code alist))) - (and entry - (let loop ((translators (cdr entry))) - (and (not (null? translators)) - (if (or (eq? (caar translators) true) - ((caar translators) frame)) - (cdar translators) - (loop (cdr translators))))))))))) - (if translator - (translator error-type frame error-code) - (make-error-condition error-type - '() - repl-environment))))))))) - -(define (anomalous-microcode-error error-code interrupt-enables) - (set-interrupt-enables! interrupt-enables) - (with-proceed-point proceed-value-filter - (lambda () - (signal-error - (make-error-condition - error-type:anomalous - (list (or (and (exact-nonnegative-integer? error-code) - (microcode-error/code->name error-code)) - error-code)) - repl-environment))))) +;;;; Restart Bindings + +(define (unbound-variable/store-value continuation environment name thunk) + (bind-restart 'STORE-VALUE + (lambda (port) + (write-string "Define " port) + (write name port) + (write-string " to a given value." port)) + (lambda (value) + (local-assignment environment name value) + (continuation unspecific)) + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (let ((prompt (string-append "Define " (write-to-string name) " as"))) + (lambda () + (values (prompt-for-evaluated-expression prompt environment))))) + (thunk)))) + +(define (unassigned-variable/store-value continuation environment name thunk) + (bind-restart 'STORE-VALUE + (lambda (port) + (write-string "Set " port) + (write name port) + (write-string " to a given value." port)) + (lambda (value) + (environment-assign! environment name value) + (continuation unspecific)) + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (let ((prompt (string-append "Define " (write-to-string name) " as"))) + (lambda () + (values (prompt-for-evaluated-expression prompt environment))))) + (thunk)))) + +(define (variable/use-value continuation environment name thunk) + (let ((continuation (continuation/next-continuation continuation))) + (if continuation + (bind-restart 'USE-VALUE + (lambda (port) + (write-string "Specify a value to use instead of " port) + (write name port) + (write-string "." port)) + continuation + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (let ((prompt + (string-append "Value to use instead of " + (write-to-string name)))) + (lambda () + (values + (prompt-for-evaluated-expression prompt environment))))) + (thunk))) + (thunk)))) + +(define (inapplicable-object/use-value continuation operands thunk) + (let ((continuation (continuation/next-continuation continuation))) + (if continuation + (bind-restart 'USE-VALUE "Specify a procedure to use in its place." + (lambda (operator) + (within-continuation continuation + (lambda () + (apply operator operands)))) + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (lambda () + (values (prompt-for-evaluated-expression "New procedure")))) + (thunk))) + (thunk)))) -;;;; Frame Decomposition - -(define-integrable (standard-frame/expression frame) - (stack-frame/ref frame 1)) +(define (illegal-arg-signaller type) + (let ((signal (condition-signaller type '(DATUM OPERATOR OPERAND)))) + (lambda (continuation operator operands index) + (illegal-argument/use-value continuation operator operands index + (lambda () + (signal continuation (list-ref operands index) operator index)))))) + +(define (illegal-argument/use-value continuation operator operands index thunk) + (let ((continuation (continuation/next-continuation continuation))) + (if continuation + (bind-restart 'USE-VALUE "Specify an argument to use in its place." + (lambda (operand) + (within-continuation continuation + (lambda () + (apply operator + (substitute-element operands index operand))))) + (lambda (restart) + (restart/put! restart 'INTERACTIVE + (lambda () + (values (prompt-for-evaluated-expression "New argument")))) + (thunk))) + (thunk)))) + +(define (substitute-element list index element) + (let loop ((list list) (i 0)) + (if (= i index) + (cons element (cdr list)) + (cons (car list) (loop (cdr list) (+ i 1)))))) + +;;;; Continuation Parsing -(define-integrable (standard-frame/environment frame) - (stack-frame/ref frame 2)) +(define (continuation/next-continuation continuation) + (let ((first-subproblem (continuation/first-subproblem continuation))) + (and first-subproblem + (let ((next-subproblem (stack-frame/next first-subproblem))) + (and next-subproblem + (stack-frame->continuation next-subproblem)))))) -(define (standard-frame/variable? frame) - (variable? (standard-frame/expression frame))) +(define-integrable (frame/type frame) + (microcode-return/code->name (stack-frame/return-code frame))) -(define-integrable (expression-only-frame/expression frame) - (stack-frame/ref frame 1)) +(define (apply-frame? frame) + (let ((code (stack-frame/return-code frame))) + (and code + (or (= return-code:internal-apply code) + (= return-code:internal-apply-val code))))) -(define-integrable (internal-apply-frame/operator frame) +(define-integrable (apply-frame/operator frame) (stack-frame/ref frame 3)) -(define-integrable (internal-apply-frame/operand frame index) +(define-integrable (apply-frame/operand frame index) (stack-frame/ref frame (+ 4 index))) -(define-integrable (internal-apply-frame/n-operands frame) - (- (stack-frame/length frame) 4)) +(define (apply-frame/operands frame) + (let ((elements (stack-frame/elements frame))) + (subvector->list elements 4 (vector-length elements)))) + +(define-integrable (eval-frame/expression frame) + (stack-frame/ref frame 1)) + +(define-integrable (eval-frame/environment frame) + (stack-frame/ref frame 2)) + +(define (pop-return-frame/value continuation) + (let loop ((frame (continuation->stack-frame continuation))) + (if (or (not frame) (stack-frame/subproblem? frame)) + (error "Can't find POP-RETURN-ERROR frame.")) + (if (let ((code (stack-frame/return-code frame))) + (and code + (= return-code:pop-return-error code))) + (stack-frame/ref frame 1) + (loop (stack-frame/next frame))))) + +(define-integrable (reference-trap-frame/name frame) + (stack-frame/ref frame 2)) + +(define-integrable (reference-trap-frame/environment frame) + (stack-frame/ref frame 3)) -(define (internal-apply-frame/select frame selector) - (if (exact-nonnegative-integer? selector) - (internal-apply-frame/operand frame selector) - (selector frame))) +(define-integrable (compiled-code-error-frame? frame) + (let ((code (stack-frame/return-code frame))) + (and code + (= return-code:compiler-error-restart code)))) -(define ((internal-apply-frame/operator-filter . operators) frame) - (memq (internal-apply-frame/operator frame) operators)) +(define-integrable (compiled-code-error-frame/irritant frame) + (stack-frame/ref frame 2)) -(define internal-apply-frame/fasload?) -(define internal-apply-frame/fasdump?) +(define return-code:internal-apply) +(define return-code:internal-apply-val) +(define return-code:pop-return-error) +(define return-code:compiler-error-restart) + +;;;; Utilities + +(define (write-code object what port) + (if (integer? object) + (begin + (write-string what port) + (write-string " " port) + (write object port)) + (begin + (write-string "the " port) + (write object port) + (write-string " " port) + (write-string what port)))) + +(define (normalize-trap-code-name name) + (let loop ((prefixes '("floating-point " "integer "))) + (if (not (null? prefixes)) + (if (string-prefix-ci? (car prefixes) name) + (set! name (string-tail name (string-length (car prefixes)))) + (loop (cdr prefixes))))) + (let loop ((suffixes '(" trap" " fault"))) + (if (not (null? suffixes)) + (if (string-suffix-ci? (car suffixes) name) + (set! name + (string-head name + (- (string-length name) + (string-length (car suffixes))))) + (loop (cdr suffixes))))) + (cond ((string-ci=? "underflow" name) 'UNDERFLOW) + ((string-ci=? "overflow" name) 'OVERFLOW) + ((or (string-ci=? "divide by 0" name) + (string-ci=? "divide by zero" name)) + 'DIVIDE-BY-ZERO) + (else false))) + +(define (initialize-package!) -(define (internal-apply-frame/add-fluid-binding-name frame) - (let ((name (internal-apply-frame/operand frame 1))) - (cond ((variable? name) (variable-name name)) - ((symbol? name) name) - (else name)))) +(set! return-code:internal-apply + (microcode-return/name->code 'INTERNAL-APPLY)) + +(set! return-code:internal-apply-val + (microcode-return/name->code 'INTERNAL-APPLY-VAL)) + +(set! return-code:pop-return-error + (microcode-return/name->code 'POP-RETURN-ERROR)) + +(set! return-code:compiler-error-restart + (microcode-return/name->code 'COMPILER-ERROR-RESTART)) + +(set! error-handler-vector + (make-vector (microcode-error/code-limit) + (lambda (error-code interrupt-enables) + (set-interrupt-enables! interrupt-enables) + (call-with-current-continuation + (lambda (continuation) + (default-error-handler continuation error-code)))))) + +(set! condition-type:anomalous-microcode-error + (make-condition-type 'ANOMALOUS-MICROCODE-ERROR condition-type:error + '(ERROR-CODE EXTRA) + (lambda (condition port) + (write-string "Anomalous microcode error " port) + (write (access-condition condition 'ERROR-CODE) port) + (write-string " -- get a wizard." port)))) + +(set! default-error-handler + (let ((signal + (condition-signaller condition-type:anomalous-microcode-error + '(ERROR-CODE EXTRA)))) + (lambda (continuation error-code) + (let ((doit + (lambda (error-code extra) + (signal continuation + (or (and (exact-nonnegative-integer? error-code) + (microcode-error/code->name error-code)) + error-code) + extra)))) + (if (vector? error-code) + (doit (vector-ref error-code 0) + (subvector->list error-code 1 (vector-length error-code))) + (doit error-code '())))))) + +(let ((fixed-objects (get-fixed-objects-vector))) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'SYSTEM-ERROR-VECTOR) + error-handler-vector) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'ERROR-PROCEDURE) + (lambda (datum arguments environment) + environment + (apply error datum arguments))) + (vector-set! fixed-objects + (fixed-objects-vector-slot 'COMPILER-ERROR-PROCEDURE) + error) + ((ucode-primitive set-fixed-objects-vector!) fixed-objects)) + +;;;; Variable Errors + +(define-error-handler 'UNBOUND-VARIABLE + (let ((signal + (condition-signaller condition-type:unbound-variable + '(ENVIRONMENT LOCATION)))) + (lambda (continuation) + (let ((signal-reference + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (variable/use-value continuation environment name + (lambda () + (signal continuation environment name))))))) + (signal-other + (lambda (environment name) + (unbound-variable/store-value continuation environment name + (lambda () + (signal continuation environment name))))) + (frame (continuation/first-subproblem continuation))) + (case (frame/type frame) + ((EVAL-ERROR) + (let ((expression (eval-frame/expression frame))) + (if (variable? expression) + (signal-reference (eval-frame/environment frame) + (variable-name expression))))) + ((ASSIGNMENT-CONTINUE) + (signal-other (eval-frame/environment frame) + (assignment-name (eval-frame/expression frame)))) + ((ACCESS-CONTINUE) + (signal-reference (pop-return-frame/value continuation) + (access-name (eval-frame/expression frame)))) + ((INTERNAL-APPLY INTERNAL-APPLY-VAL) + (let ((operator (apply-frame/operator frame))) + (cond ((eq? (ucode-primitive lexical-reference) operator) + (signal-reference (apply-frame/operand frame 0) + (apply-frame/operand frame 1))) + ((eq? (ucode-primitive lexical-assignment) operator) + (signal-other (apply-frame/operand frame 0) + (apply-frame/operand frame 1))) + ((eq? (ucode-primitive add-fluid-binding! 3) operator) + (signal-other (apply-frame/operand frame 0) + (let ((name (apply-frame/operand frame 1))) + (if (variable? name) + (variable-name name) + name)))) + ((eq? (ucode-primitive environment-link-name) operator) + (signal-other (apply-frame/operand frame 0) + (apply-frame/operand frame 2)))))) + ((COMPILER-REFERENCE-TRAP-RESTART + COMPILER-SAFE-REFERENCE-TRAP-RESTART) + (signal-reference (reference-trap-frame/environment frame) + (reference-trap-frame/name frame))) + ((COMPILER-ASSIGNMENT-TRAP-RESTART + COMPILER-UNASSIGNED?-TRAP-RESTART + COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) + (signal-other (reference-trap-frame/environment frame) + (reference-trap-frame/name frame)))))))) + +(define-error-handler 'UNASSIGNED-VARIABLE + (let ((signal + (condition-signaller condition-type:unassigned-variable + '(ENVIRONMENT LOCATION)))) + (lambda (continuation) + (let ((signal + (lambda (environment name) + (unassigned-variable/store-value continuation environment name + (lambda () + (variable/use-value continuation environment name + (lambda () + (signal continuation environment name))))))) + (frame (continuation/first-subproblem continuation))) + (case (frame/type frame) + ((EVAL-ERROR) + (let ((expression (eval-frame/expression frame))) + (if (variable? expression) + (signal (eval-frame/environment frame) + (variable-name expression))))) + ((ACCESS-CONTINUE) + (signal (pop-return-frame/value continuation) + (access-name (eval-frame/expression frame)))) + ((INTERNAL-APPLY INTERNAL-APPLY-VAL) + (if (eq? (ucode-primitive lexical-reference) + (apply-frame/operator frame)) + (signal (apply-frame/operand frame 0) + (apply-frame/operand frame 1)))) + ((COMPILER-REFERENCE-TRAP-RESTART) + (signal (reference-trap-frame/environment frame) + (reference-trap-frame/name frame)))))))) + +(set! condition-type:unlinkable-variable + (make-condition-type 'UNLINKABLE-VARIABLE condition-type:variable-error '() + (lambda (condition port) + (write-string "The variable " port) + (write (access-condition condition 'NAME) port) + (write-string " is already bound; it cannot be linked to." port)))) + +(define-error-handler 'BAD-ASSIGNMENT + (let ((signal + (condition-signaller condition-type:unlinkable-variable + '(ENVIRONMENT LOCATION)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (and (apply-frame? frame) + (eq? (ucode-primitive environment-link-name) + (apply-frame/operator frame))) + (signal continuation + (apply-frame/operand frame 0) + (apply-frame/operand frame 2))))))) + +;;;; Argument Errors + +(define signal-bad-range-argument + (illegal-arg-signaller condition-type:bad-range-argument)) + +(define signal-wrong-type-argument + (illegal-arg-signaller condition-type:wrong-type-argument)) + +(define (define-arg-error error-code n signal) + (define-error-handler error-code + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (signal continuation + (apply-frame/operator frame) + (apply-frame/operands frame) + n)))))) + +(define-arg-error 'BAD-RANGE-ARGUMENT-0 0 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-1 1 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-2 2 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-3 3 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-4 4 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-5 5 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-6 6 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-7 7 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-8 8 signal-bad-range-argument) +(define-arg-error 'BAD-RANGE-ARGUMENT-9 9 signal-bad-range-argument) + +(define-arg-error 'WRONG-TYPE-ARGUMENT-0 0 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-1 1 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-2 2 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-3 3 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-4 4 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-5 5 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-6 6 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-7 7 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-8 8 signal-wrong-type-argument) +(define-arg-error 'WRONG-TYPE-ARGUMENT-9 9 signal-wrong-type-argument) + +;;;; Primitive Errors + +(define (define-primitive-error error-name type) + (define-error-handler error-name + (let ((signal (condition-signaller type '(OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (primitive-procedure? operator) + (signal continuation + operator + (apply-frame/operands frame)))))))))) + +(set! condition-type:primitive-procedure-error + (make-condition-type 'PRIMITIVE-PROCEDURE-ERROR condition-type:error + '(OPERATOR OPERANDS) + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " signalled an anonymous error." port)))) + +(define-primitive-error 'EXTERNAL-RETURN + condition-type:primitive-procedure-error) + +(set! condition-type:unimplemented-primitive + (make-condition-type 'UNIMPLEMENTED-PRIMITIVE + condition-type:primitive-procedure-error + '() + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " is not implemented in this version of Scheme." port)))) + +(define-primitive-error 'UNIMPLEMENTED-PRIMITIVE + condition-type:unimplemented-primitive) + +(set! condition-type:unimplemented-primitive-for-os + (make-condition-type 'UNIMPLEMENTED-PRIMITIVE-FOR-OS + condition-type:unimplemented-primitive + '() + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " is not implemented for this operating system." port)))) + +(define-primitive-error 'UNDEFINED-PRIMITIVE + condition-type:unimplemented-primitive-for-os) + +(set! condition-type:compiled-code-error + (make-condition-type 'COMPILED-CODE-ERROR + condition-type:primitive-procedure-error + '() + (lambda (condition port) + (write-string "The open-coded primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " was called with an inappropriate argument." port)))) + +(define-error-handler 'COMPILED-CODE-ERROR + (let ((signal + (condition-signaller condition-type:compiled-code-error + '(OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (compiled-code-error-frame? frame) + (let ((irritant (compiled-code-error-frame/irritant frame))) + (if (primitive-procedure? irritant) + (signal continuation irritant 'UNKNOWN)))))))) + +(set! condition-type:primitive-io-error + ;; Primitives that signal this error should be changed to signal a + ;; system-call error instead, since that is more descriptive. + (make-condition-type 'PRIMITIVE-IO-ERROR + condition-type:primitive-procedure-error + '() + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " signalled an anonymous I/O error." port)))) + +(define-error-handler 'IO-ERROR + (let ((signal + (condition-signaller condition-type:primitive-io-error + '(OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (signal continuation + (apply-frame/operator frame) + (apply-frame/operands frame))))))) + +(set! condition-type:out-of-file-handles + (make-condition-type 'OUT-OF-FILE-HANDLES + condition-type:primitive-procedure-error + '() + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string " could not allocate a channel or subprocess." port)))) + +(define-error-handler 'OUT-OF-FILE-HANDLES + (let ((signal + (condition-signaller condition-type:out-of-file-handles + '(OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (or (eq? (ucode-primitive file-open-input-channel) operator) + (eq? (ucode-primitive file-open-output-channel) operator) + (eq? (ucode-primitive file-open-io-channel) operator) + (eq? (ucode-primitive file-open-append-channel) + operator)) + (signal-open-file-error continuation + (apply-frame/operand frame 0)) + (signal continuation + operator + (apply-frame/operands frame))))))))) + +(define signal-open-file-error + (condition-signaller condition-type:open-file-error '(FILENAME))) + +(set! condition-type:system-call-error + (make-condition-type 'SYSTEM-CALL-ERROR + condition-type:primitive-procedure-error + '(SYSTEM-CALL ERROR-TYPE) + (lambda (condition port) + (write-string "The primitive " port) + (write-operator (access-condition condition 'OPERATOR) port) + (write-string ", while executing " port) + (write-code (access-condition condition 'SYSTEM-CALL) "system call" port) + (write-string ", received " port) + (write-code (access-condition condition 'ERROR-TYPE) "error" port) + (write-string "." port)))) + +(define-low-level-handler 'SYSTEM-CALL + (let ((signal + (condition-signaller condition-type:system-call-error + '(OPERATOR OPERANDS SYSTEM-CALL ERROR-TYPE)))) + (lambda (continuation error-code) + (let ((frame (continuation/first-subproblem continuation))) + (if (and (apply-frame? frame) + (vector? error-code) + (= 3 (vector-length error-code))) + (signal continuation + (apply-frame/operator frame) + (apply-frame/operands frame) + (let ((system-call (vector-ref error-code 2))) + (or (microcode-system-call/code->name system-call) + system-call)) + (let ((error-type (vector-ref error-code 1))) + (or (microcode-system-call-error/code->name error-type) + error-type)))))))) -;;;; Special Handlers - -(define (wrong-number-of-arguments-error condition-type frame error-code) - error-code - (make-error-condition - condition-type - (let ((operator (internal-apply-frame/operator frame))) - (let ((arity (procedure-arity operator))) - (list (internal-apply-frame/n-operands frame) - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - operator - (error-irritant/noise char:newline) - (error-irritant/noise "minimum/maximum number of arguments:") - (car arity) - (cdr arity)))) - repl-environment)) - -(define (file-error condition-type frame error-code) - condition-type frame error-code - (make-error-condition error-type:file '() repl-environment)) - -(define (open-file-error condition-type frame error-code) - condition-type error-code - (make-error-condition error-type:open-file - (list (internal-apply-frame/operand frame 0)) - repl-environment)) - -(define (out-of-file-handles-error condition-type frame error-code) - error-code - (make-error-condition condition-type - (list (internal-apply-frame/operand frame 0)) - repl-environment)) - -(define (write-into-pure-space-error error-code interrupt-enables) - error-code - (set-interrupt-enables! interrupt-enables) - (let ((port (cmdl/output-port (nearest-cmdl)))) - (newline port) - (write-string "Automagically impurifying an object..." port)) - (call-with-current-continuation - (lambda (continuation) - (impurify - (internal-apply-frame/operand - (continuation/first-subproblem continuation) - 0))))) - -(define (bad-error-code-handler error-code interrupt-enables) - ;; This could be a "translator" except that it needs the error-code - ;; and "translators" don't normally get it. - (set-interrupt-enables! interrupt-enables) - (with-proceed-point proceed-value-filter - (lambda () - (signal-error - (make-error-condition error-type:bad-error-code - (list error-code) - repl-environment))))) - -(define error-type:bad-error-code) +;;;; FASLOAD Errors + +(define (define-fasload-error error-code type) + (define-error-handler error-code + (let ((signal (condition-signaller type '(FILENAME OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (or (eq? (ucode-primitive load-band) operator) + (eq? (ucode-primitive binary-fasload) operator)) + (signal continuation + (apply-frame/operand frame 0) + operator + (apply-frame/operands frame)))))))))) + +(set! condition-type:fasload-error + (make-condition-type 'FASLOAD-ERROR condition-type:file-error + '(OPERATOR OPERANDS) + false)) + +(set! condition-type:fasl-file-bad-data + (make-condition-type 'FASL-FILE-BAD-DATA condition-type:fasload-error '() + (lambda (condition port) + (write-string "Attempt to read binary file " port) + (write (access-condition condition 'FILENAME) port) + (write-string " failed: either it's not binary or the wrong version." + port)))) + +(define-fasload-error 'FASL-FILE-BAD-DATA + condition-type:fasl-file-bad-data) + +(set! condition-type:fasl-file-compiled-mismatch + (make-condition-type 'FASL-FILE-COMPILED-MISMATCH + condition-type:fasl-file-bad-data + '() + false)) + +(define-fasload-error 'FASL-FILE-COMPILED-MISMATCH + condition-type:fasl-file-compiled-mismatch) + +(set! condition-type:fasl-file-too-big + (make-condition-type 'FASL-FILE-TOO-BIG condition-type:fasload-error '() + (lambda (condition port) + (write-string "Attempt to read binary file " port) + (write (access-condition condition 'FILENAME) port) + (write-string " failed: it's too large to fit in the heap." port)))) + +(define-fasload-error 'FASL-FILE-TOO-BIG + condition-type:fasl-file-too-big) + +(set! condition-type:wrong-arity-primitives + (make-condition-type 'WRONG-ARITY-PRIMITIVES condition-type:fasload-error '() + (lambda (condition port) + (write-string "Attempt to read binary file " port) + (write (access-condition condition 'FILENAME) port) + (write-string " failed: it contains primitives with incorrect arity." + port)))) + +(define-fasload-error 'WRONG-ARITY-PRIMITIVES + condition-type:wrong-arity-primitives) + +(set! condition-type:fasload-band + (make-condition-type 'FASLOAD-BAND condition-type:fasl-file-bad-data '() + false)) + +(define-error-handler 'FASLOAD-BAND + (let ((signal + (condition-signaller condition-type:fasload-band + '(FILENAME OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (eq? (ucode-primitive binary-fasload) operator) + (signal continuation + (apply-frame/operand frame 0) + operator + (apply-frame/operands frame))))))))) -(define error-type:anomalous) -(define error-type:bad-range-argument) -(define error-type:failed-argument-coercion) -(define error-type:fasdump) -(define error-type:fasload) -(define error-type:file) -(define error-type:illegal-argument) -(define error-type:open-file) -(define error-type:premature-write-termination) -(define error-type:random-internal) -(define error-type:wrong-type-argument) - -(define (build-condition-types!) - (set! error-type:random-internal - (make-base-type "Random internal error")) - (set! error-type:illegal-argument - (make-base-type "Illegal argument")) - (set! error-type:wrong-type-argument - (make-condition-type (list error-type:illegal-argument) - "Illegal datum")) - (set! error-type:bad-range-argument - (make-condition-type (list error-type:illegal-argument) - "Datum out of range")) - (set! error-type:failed-argument-coercion - (make-base-type "Argument cannot be coerced to floating point")) - (set! error-type:file - (make-base-type "File operation error")) - (set! error-type:open-file - (make-condition-type (list error-type:file) "Unable to open file")) - (set! error-type:fasdump - (make-condition-type (list error-type:file) "Fasdump error")) - (set! error-type:fasload - (make-condition-type (list error-type:file) "Fasload error")) - (set! error-type:premature-write-termination - (make-condition-type (list error-type:file) - "Channel write terminated prematurely")) - (set! error-type:anomalous - (make-internal-type "Anomalous microcode error")) - unspecific) - -(define (make-base-type message) - (make-condition-type (list condition-type:error) message)) - -(define (make-internal-type message) - (make-condition-type (list error-type:random-internal) - (string-append message " -- get a wizard"))) - -(define (make-bad-range-type n) - (make-condition-type (list error-type:bad-range-argument) - (string-append "Datum out of range in " - (vector-ref nth-string n) - " argument position"))) - -(define (make-wrong-type-type n) - (make-condition-type (list error-type:wrong-type-argument) - (string-append "Illegal datum in " - (vector-ref nth-string n) - " argument position"))) - -(define (make-failed-arg-type n) - (make-condition-type (list error-type:failed-argument-coercion) - (string-append - (string-capitalize (vector-ref nth-string n)) - " argument cannot be coerced to floating point"))) - -(define nth-string - '#("first" "second" "third" "fourth" "fifth" "sixth" "seventh" "eighth" - "ninth" "tenth")) +;;;; Miscellaneous Errors + +(set! condition-type:inapplicable-object + (make-condition-type 'INAPPLICABLE-OBJECT condition-type:illegal-datum + '(OPERANDS) + (lambda (condition port) + (write-string "The object " port) + (write (access-condition condition 'DATUM) port) + (write-string " is not applicable." port)))) + +(define-error-handler 'UNDEFINED-PROCEDURE + (let ((signal + (condition-signaller condition-type:inapplicable-object + '(DATUM OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame)) + (operands (apply-frame/operands frame))) + (inapplicable-object/use-value continuation operands + (lambda () + (signal continuation operator operands))))))))) + +(define-error-handler 'WRONG-NUMBER-OF-ARGUMENTS + (let ((signal + (condition-signaller condition-type:wrong-number-of-arguments + '(DATUM TYPE OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (signal continuation + operator + (procedure-arity operator) + (apply-frame/operands frame)))))))) + +(define-error-handler 'FLOATING-OVERFLOW + (let ((signal + (condition-signaller condition-type:floating-point-overflow + '(OPERATOR OPERANDS)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (signal continuation + (apply-frame/operator frame) + (apply-frame/operands frame))))))) -(define (microcode-error-type name) - (vector-ref microcode-error-types (microcode-error name))) - -(define microcode-error-types) - -(define (make-error-types) - (let ((types (make-vector (microcode-error/code-limit) false))) - (for-each - (lambda (entry) - (vector-set! types (microcode-error (car entry)) (cadr entry))) - `( - (BAD-ASSIGNMENT ,(make-internal-type "Illegal to rebind variable")) - (BAD-ERROR-CODE ,(make-internal-type "Illegal error code")) - (BAD-FRAME ,(make-internal-type "Illegal environment frame")) - (BAD-INTERRUPT-CODE ,(make-internal-type "Illegal interrupt code")) - (BAD-RANGE-ARGUMENT-0 ,(make-bad-range-type 0)) - (BAD-RANGE-ARGUMENT-1 ,(make-bad-range-type 1)) - (BAD-RANGE-ARGUMENT-2 ,(make-bad-range-type 2)) - (BAD-RANGE-ARGUMENT-3 ,(make-bad-range-type 3)) - (BAD-RANGE-ARGUMENT-4 ,(make-bad-range-type 4)) - (BAD-RANGE-ARGUMENT-5 ,(make-bad-range-type 5)) - (BAD-RANGE-ARGUMENT-6 ,(make-bad-range-type 6)) - (BAD-RANGE-ARGUMENT-7 ,(make-bad-range-type 7)) - (BAD-RANGE-ARGUMENT-8 ,(make-bad-range-type 8)) - (BAD-RANGE-ARGUMENT-9 ,(make-bad-range-type 9)) - (BROKEN-CVARIABLE ,(make-internal-type "Broken compiled variable")) - (BROKEN-VARIABLE-CACHE - ,(make-internal-type "Broken variable value cell")) - (COMPILED-CODE-ERROR - ,(make-condition-type (list error-type:illegal-argument) - "Compiled code error")) - (EXECUTE-MANIFEST-VECTOR - ,(make-internal-type "Attempt to execute manifest vector")) - (EXTERNAL-RETURN - ,(make-internal-type "Error during external application")) - (FAILED-ARG-1-COERCION ,(make-failed-arg-type 0)) - (FAILED-ARG-2-COERCION ,(make-failed-arg-type 1)) - (FASDUMP-ENVIRONMENT - ,(make-condition-type - (list error-type:fasdump) - "Object to dump is or points to environment objects")) - (FASL-FILE-BAD-DATA - ,(make-condition-type (list error-type:fasload) "Bad binary file")) - (FASL-FILE-TOO-BIG - ,(make-condition-type (list error-type:fasload) "Not enough room")) - (FASLOAD-BAND - ,(make-condition-type - (list error-type:fasload) - "Binary file contains a scheme image (band), not an object")) - (FASLOAD-COMPILED-MISMATCH - ,(make-condition-type - (list error-type:fasload) - "Binary file contains compiled code for a different microcode")) - (FLOATING-OVERFLOW ,(make-base-type "Floating point overflow")) - (ILLEGAL-REFERENCE-TRAP ,(make-internal-type "Illegal reference trap")) - (INAPPLICABLE-CONTINUATION - ,(make-internal-type "Inapplicable continuation")) - (IO-ERROR ,(make-condition-type (list error-type:file) "I/O error")) - (SYSTEM-CALL ,(make-internal-type "Error in system call")) - (OUT-OF-FILE-HANDLES - ,(make-condition-type (list error-type:open-file) - "Too many open files")) - (UNASSIGNED-VARIABLE ,(make-base-type "Unassigned variable")) - (UNBOUND-VARIABLE ,(make-base-type "Unbound variable")) - (UNDEFINED-PRIMITIVE-OPERATION - ,(make-internal-type "Undefined primitive procedure")) - (UNDEFINED-PROCEDURE - ,(make-base-type "Application of inapplicable object")) - (UNDEFINED-USER-TYPE ,(make-internal-type "Undefined type code")) - (UNIMPLEMENTED-PRIMITIVE - ,(make-internal-type "Unimplemented primitive procedure")) - (WRONG-ARITY-PRIMITIVES - ,(make-condition-type - (list error-type:fasload) - "Primitives in binary file have the wrong arity")) - (WRONG-NUMBER-OF-ARGUMENTS - ,(make-base-type "Wrong number of arguments")) - (WRONG-TYPE-ARGUMENT-0 ,(make-wrong-type-type 0)) - (WRONG-TYPE-ARGUMENT-1 ,(make-wrong-type-type 1)) - (WRONG-TYPE-ARGUMENT-2 ,(make-wrong-type-type 2)) - (WRONG-TYPE-ARGUMENT-3 ,(make-wrong-type-type 3)) - (WRONG-TYPE-ARGUMENT-4 ,(make-wrong-type-type 4)) - (WRONG-TYPE-ARGUMENT-5 ,(make-wrong-type-type 5)) - (WRONG-TYPE-ARGUMENT-6 ,(make-wrong-type-type 6)) - (WRONG-TYPE-ARGUMENT-7 ,(make-wrong-type-type 7)) - (WRONG-TYPE-ARGUMENT-8 ,(make-wrong-type-type 8)) - (WRONG-TYPE-ARGUMENT-9 ,(make-wrong-type-type 9)) - )) - types)) +(define-error-handler 'WRITE-INTO-PURE-SPACE + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((object (apply-frame/operand frame 0))) + (let ((port (nearest-cmdl/output-port))) + (newline port) + (write-string "Automagically impurifying an object..." port)) + (impurify object) + (continuation object)))))) + +(set! condition-type:impurify-object-too-large + (make-condition-type 'IMPURIFY-OBJECT-TOO-LARGE + condition-type:bad-range-argument + '() + (lambda (condition port) + (write-string "Object is too large to be impurified: " port) + (write (access-condition condition 'DATUM) port)))) + +(define-error-handler 'IMPURIFY-OBJECT-TOO-LARGE + (let ((signal + (condition-signaller condition-type:impurify-object-too-large + '(DATUM OPERATOR OPERAND)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (eq? (ucode-primitive primitive-impurify) operator) + (signal continuation + (apply-frame/operand frame 0) + operator + 0)))))))) + +(set! condition-type:fasdump-environment + (make-condition-type 'FASDUMP-ENVIRONMENT condition-type:bad-range-argument + '() + (lambda (condition port) + (write-string + "Object cannot be dumped because it contains an environment:" + port) + (write (access-condition condition 'DATUM) port)))) + +(define-error-handler 'FASDUMP-ENVIRONMENT + (let ((signal + (condition-signaller condition-type:fasdump-environment + '(DATUM OPERATOR OPERAND)))) + (lambda (continuation) + (let ((frame (continuation/first-subproblem continuation))) + (if (apply-frame? frame) + (let ((operator (apply-frame/operator frame))) + (if (eq? (ucode-primitive primitive-fasdump) operator) + (signal continuation + (apply-frame/operand frame 0) + operator + 0)))))))) -(define (make-error-alists error-code-limit) - (let ((alists (make-vector error-code-limit '()))) - - (define (define-total-error-handler error-type handler) - (vector-set! alists - (microcode-error error-type) - handler)) - - (define (define-error-handler error-type frame-type frame-filter handler) - (let ((error-code (microcode-error error-type)) - (return-code (microcode-return frame-type))) - (let ((entry (vector-ref alists error-code))) - (cond ((pair? entry) - (let ((entry* (assv return-code entry))) - (if entry* - (let ((entry** (assq frame-filter (cdr entry*)))) - (if entry** - (set-cdr! entry** handler) - (set-cdr! entry* - (let ((entry** - (cons frame-filter handler))) - (if (eq? frame-filter true) - (append! (cdr entry*) - (list entry**)) - (cons entry** (cdr entry*))))))) - (vector-set! alists - error-code - (cons (list return-code - (cons frame-filter handler)) - entry))))) - ((null? entry) - (vector-set! alists - error-code - (list (list return-code - (cons frame-filter handler))))) - (else - (error "Can't overwrite error handler" entry))))) - unspecific) - - (define (define-standard-frame-handler error-type frame-type frame-filter - irritant) - (define-error-handler error-type frame-type frame-filter - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (irritant (standard-frame/expression frame))) - (standard-frame/environment frame))))) - - (define (define-expression-frame-handler error-type frame-type frame-filter - irritant) - (define-error-handler error-type frame-type frame-filter - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (irritant (expression-only-frame/expression frame))) - repl-environment)))) - - (define (define-apply-handler definer) - (for-each definer '(INTERNAL-APPLY INTERNAL-APPLY-VAL))) - - (define (define-internal-apply-handler error-type environment irritant - . operators) - (define-apply-handler - (lambda (return-address) - (define-error-handler error-type return-address - (apply internal-apply-frame/operator-filter operators) - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (internal-apply-frame/select frame irritant)) - (if environment - (internal-apply-frame/select frame environment) - repl-environment))))))) - - (define (define-operator-handler error-type) - (define-apply-handler - (lambda (return-address) - (define-error-handler error-type return-address true - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (internal-apply-frame/operator frame)) - repl-environment)))))) - - (define (define-operand-handler error-type irritant #!optional filter) - (define-apply-handler - (lambda (return-address) - (define-error-handler error-type return-address - (if (default-object? filter) true filter) - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (internal-apply-frame/select frame irritant) - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - (internal-apply-frame/operator frame)) - repl-environment)))))) - - (define (define-reference-trap-handler error-type frame-type) - (define-error-handler error-type frame-type true - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (stack-frame/ref frame 2)) - (stack-frame/ref frame 3))))) - - (define-standard-frame-handler 'UNBOUND-VARIABLE 'EVAL-ERROR - standard-frame/variable? variable-name) - - (define-standard-frame-handler 'UNBOUND-VARIABLE 'ASSIGNMENT-CONTINUE true - assignment-name) - - (define-expression-frame-handler 'UNBOUND-VARIABLE 'ACCESS-CONTINUE true - access-name) - - (define-internal-apply-handler 'UNBOUND-VARIABLE 0 1 - (ucode-primitive lexical-reference) - (ucode-primitive lexical-assignment)) - - (define-internal-apply-handler 'UNBOUND-VARIABLE 0 - internal-apply-frame/add-fluid-binding-name - (ucode-primitive add-fluid-binding! 3)) - - (define-internal-apply-handler 'UNBOUND-VARIABLE 0 2 - (ucode-primitive environment-link-name)) - - (define-reference-trap-handler 'UNBOUND-VARIABLE - 'COMPILER-REFERENCE-TRAP-RESTART) - - (define-reference-trap-handler 'UNBOUND-VARIABLE - 'COMPILER-SAFE-REFERENCE-TRAP-RESTART) - - (define-reference-trap-handler 'UNBOUND-VARIABLE - 'COMPILER-ASSIGNMENT-TRAP-RESTART) - - (define-reference-trap-handler 'UNBOUND-VARIABLE - 'COMPILER-UNASSIGNED?-TRAP-RESTART) - - (define-reference-trap-handler 'UNBOUND-VARIABLE - 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) - - (define-internal-apply-handler 'BAD-ASSIGNMENT 1 2 - (ucode-primitive environment-link-name)) - - (define-internal-apply-handler 'ILLEGAL-REFERENCE-TRAP 1 2 - (ucode-primitive environment-link-name)) - - (define-standard-frame-handler 'UNASSIGNED-VARIABLE 'EVAL-ERROR - standard-frame/variable? variable-name) - - (define-expression-frame-handler 'UNASSIGNED-VARIABLE 'ACCESS-CONTINUE true - access-name) - - (define-internal-apply-handler 'UNASSIGNED-VARIABLE 0 1 - (ucode-primitive lexical-reference)) - - (define-reference-trap-handler 'UNASSIGNED-VARIABLE - 'COMPILER-REFERENCE-TRAP-RESTART) - - (define-reference-trap-handler 'UNASSIGNED-VARIABLE - 'COMPILER-OPERATOR-LOOKUP-TRAP-RESTART) - - (define-expression-frame-handler 'BAD-FRAME 'ACCESS-CONTINUE true - access-environment) - - (define-expression-frame-handler 'BAD-FRAME 'IN-PACKAGE-CONTINUE true - in-package-environment) - - (define-internal-apply-handler 'BAD-FRAME 0 2 - (ucode-primitive environment-link-name)) - - (define-standard-frame-handler 'BROKEN-CVARIABLE 'EVAL-ERROR - standard-frame/variable? variable-name) - - (define-standard-frame-handler 'BROKEN-CVARIABLE 'ASSIGNMENT-CONTINUE true - assignment-name) - - (define-apply-handler - (lambda (return-address) - (define-error-handler 'WRONG-NUMBER-OF-ARGUMENTS return-address true - wrong-number-of-arguments-error))) - - (define-operator-handler 'UNDEFINED-PROCEDURE) - (define-operator-handler 'UNDEFINED-PRIMITIVE-OPERATION) - (define-operator-handler 'UNIMPLEMENTED-PRIMITIVE) - (define-operator-handler 'EXTERNAL-RETURN) - - (define-operand-handler 'FAILED-ARG-1-COERCION 0) - (define-operand-handler 'FAILED-ARG-2-COERCION 1) - - (define-operand-handler 'WRONG-TYPE-ARGUMENT-0 0) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-1 1) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-2 2) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-3 3) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-4 4) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-5 5) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-6 6) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-7 7) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-8 8) - (define-operand-handler 'WRONG-TYPE-ARGUMENT-9 9) - - (define-operand-handler 'BAD-RANGE-ARGUMENT-0 0) - (define-operand-handler 'BAD-RANGE-ARGUMENT-1 1) - (define-operand-handler 'BAD-RANGE-ARGUMENT-2 2) - (define-operand-handler 'BAD-RANGE-ARGUMENT-3 3) - (define-operand-handler 'BAD-RANGE-ARGUMENT-4 4) - (define-operand-handler 'BAD-RANGE-ARGUMENT-5 5) - (define-operand-handler 'BAD-RANGE-ARGUMENT-6 6) - (define-operand-handler 'BAD-RANGE-ARGUMENT-7 7) - (define-operand-handler 'BAD-RANGE-ARGUMENT-8 8) - (define-operand-handler 'BAD-RANGE-ARGUMENT-9 9) - - (define-operand-handler 'FASL-FILE-TOO-BIG 0 - internal-apply-frame/fasload?) - (define-operand-handler 'FASL-FILE-BAD-DATA 0 - internal-apply-frame/fasload?) - (define-operand-handler 'WRONG-ARITY-PRIMITIVES 0 - internal-apply-frame/fasload?) - (define-operand-handler 'IO-ERROR 0 - internal-apply-frame/fasload?) - (define-operand-handler 'FASLOAD-COMPILED-MISMATCH 0 - internal-apply-frame/fasload?) - (define-operand-handler 'FASLOAD-BAND 0 - internal-apply-frame/fasload?) - - (define-operand-handler 'IO-ERROR 1 - internal-apply-frame/fasdump?) - (define-operand-handler 'FASDUMP-ENVIRONMENT 0 - internal-apply-frame/fasdump?) - - (define-apply-handler - (lambda (return-address) - (define-error-handler 'BAD-RANGE-ARGUMENT-0 return-address - (internal-apply-frame/operator-filter - (ucode-primitive file-open-channel) - (ucode-primitive make-directory)) - open-file-error))) - - (define-apply-handler - (lambda (return-address) - (define-error-handler 'OUT-OF-FILE-HANDLES return-address - (internal-apply-frame/operator-filter - (ucode-primitive file-open-channel)) - out-of-file-handles-error))) - - (define-apply-handler - (lambda (return-address) - (define-error-handler 'EXTERNAL-RETURN return-address - (internal-apply-frame/operator-filter - (ucode-primitive file-length) - (ucode-primitive file-copy) - (ucode-primitive file-rename) - (ucode-primitive file-remove) - (ucode-primitive link-file) - (ucode-primitive set-file-modes! 2)) - file-error))) - - (define-error-handler 'COMPILED-CODE-ERROR - 'COMPILER-ERROR-RESTART - (lambda (frame) - (primitive-procedure? (stack-frame/ref frame 2))) - (lambda (condition-type frame error-code) - error-code - (make-error-condition - condition-type - (list (error-irritant/noise ": inappropriate arguments to open-coded") - (stack-frame/ref frame 2)) - repl-environment))) - - (define-total-error-handler 'WRITE-INTO-PURE-SPACE - write-into-pure-space-error) - - (define-total-error-handler 'BAD-ERROR-CODE - bad-error-code-handler) - - alists)) \ No newline at end of file +;;;; Asynchronous Microcode Errors + +(set! condition-type:microcode-asynchronous + (make-condition-type 'MICROCODE-ASYNCHRONOUS condition-type:serious-condition + '() + false)) + +(set! condition-type:hardware-trap + (make-condition-type 'HARDWARE-TRAP condition-type:microcode-asynchronous + '(NAME CODE) + (lambda (condition port) + (write-string "Hardware trap " port) + (display (access-condition condition 'NAME) port) + (let ((code (access-condition condition 'CODE))) + (if code + (begin + (write-string ": " port) + (write code port))))))) + +(set! condition-type:user-microcode-reset + (make-condition-type 'USER-MICROCODE-RESET + condition-type:microcode-asynchronous + '() + "User microcode reset")) + +(set! hook/hardware-trap + (let ((signal-user-microcode-reset + (condition-signaller condition-type:user-microcode-reset '())) + (signal-divide-by-zero + (condition-signaller condition-type:divide-by-zero + '(OPERATOR OPERANDS))) + (signal-floating-point-overflow + (condition-signaller condition-type:floating-point-overflow + '(OPERATOR OPERANDS))) + (signal-floating-point-underflow + (condition-signaller condition-type:floating-point-underflow + '(OPERATOR OPERANDS))) + (signal-arithmetic-error + (condition-signaller condition-type:arithmetic-error + '(OPERATOR OPERANDS))) + (signal-hardware-trap + (condition-signaller condition-type:hardware-trap '(NAME CODE)))) + (lambda (name) + (call-with-current-continuation + (lambda (continuation) + (if (not name) + (signal-user-microcode-reset continuation) + (let ((code + (let ((frame + (continuation/first-subproblem continuation))) + (and (hardware-trap-frame? frame) + (hardware-trap-frame/code frame))))) + (if (string=? "SIGFPE" name) + ((case (and (string? code) + (normalize-trap-code-name code)) + ((UNDERFLOW) signal-floating-point-underflow) + ((OVERFLOW) signal-floating-point-overflow) + ((DIVIDE-BY-ZERO) signal-divide-by-zero) + (else signal-arithmetic-error)) + continuation false '()) + (signal-hardware-trap continuation name code))))))))) + +;;; end INITIALIZE-PACKAGE!. +) \ No newline at end of file diff --git a/v7/src/runtime/unsyn.scm b/v7/src/runtime/unsyn.scm index 5c4a89186..149a204d9 100644 --- a/v7/src/runtime/unsyn.scm +++ b/v7/src/runtime/unsyn.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.10 1990/09/11 22:58:02 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unsyn.scm,v 14.11 1991/02/15 18:07:27 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 @@ -50,8 +50,6 @@ MIT in each case. |# (DEFINITION ,unsyntax-DEFINITION-object) (DELAY ,unsyntax-DELAY-object) (DISJUNCTION ,unsyntax-DISJUNCTION-object) - (ERROR-COMBINATION - ,unsyntax-ERROR-COMBINATION-object) (IN-PACKAGE ,unsyntax-IN-PACKAGE-object) (LAMBDA ,unsyntax-LAMBDA-object) (OPEN-BLOCK ,unsyntax-OPEN-BLOCK-object) @@ -72,7 +70,7 @@ MIT in each case. |# (define (unsyntax-with-substitutions scode alist) (if (not (alist? alist)) - (error:illegal-datum alist 'UNSYNTAX-WITH-SUBSTITUTIONS)) + (error:wrong-type-argument alist "alist" 'UNSYNTAX-WITH-SUBSTITUTIONS)) (fluid-let ((substitutions alist)) (unsyntax scode))) @@ -103,10 +101,9 @@ MIT in each case. |# (unsyntax-objects (cdr objects))))) (define (unsyntax-error keyword message . irritants) - (error-procedure - (string-append "UNSYNTAX: " (symbol->string keyword) ": " message) - irritants - system-global-environment)) + (apply error + (string-append "UNSYNTAX: " (symbol->string keyword) ": " message) + irritants)) ;;;; Unsyntax Quanta @@ -331,7 +328,8 @@ MIT in each case. |# (define (unsyntax-lambda-list expression) (if (not (lambda? expression)) - (error:illegal-datum expression 'UNSYNTAX-LAMBDA-LIST)) + (error:wrong-type-argument expression "SCode lambda" + 'UNSYNTAX-LAMBDA-LIST)) (lambda-components** expression (lambda (name required optional rest body) name body @@ -376,8 +374,6 @@ MIT in each case. |# `(CONS-STREAM ,(unsyntax-object (car operands)) ,(unsyntax-object (delay-expression (cadr operands))))) - ((absolute-reference-to? operator 'BREAKPOINT-PROCEDURE) - (unsyntax-error-like-form operands 'BKPT)) ((lambda? operator) (lambda-components** operator (lambda (name required optional rest body) @@ -436,34 +432,6 @@ MIT in each case. |# (cdr expression)) ,@(cddr (caddr (car expression)))) expression)) - -(define (unsyntax-ERROR-COMBINATION-object combination) - (if unsyntaxer:macroize? - (unsyntax-error-like-form (combination-operands combination) 'ERROR) - (unsyntax-COMBINATION-object combination))) - -(define (unsyntax-error-like-form operands name) - (cons* name - (unsyntax-object (car operands)) - (unsyntax-objects - (let loop ((irritants (cadr operands))) - (cond ((null? irritants) '()) - ((has-substitution? irritants) (list irritants)) - ((and (combination? irritants) - (absolute-reference-to? - (combination-operator irritants) - 'LIST)) - (combination-operands irritants)) - ((and (combination? irritants) - (eq? (combination-operator irritants) cons)) - (let ((operands (combination-operands irritants))) - (cons (car operands) - (loop (cadr operands))))) - (else - ;; Actually, this is an error. But do - ;; something useful here just in case it - ;; actually happens. - (list irritants))))))) (define (unsyntax/fluid-let names values body if-malformed) (combination-components body diff --git a/v7/src/runtime/unxprm.scm b/v7/src/runtime/unxprm.scm index 5c6131a38..a745915e6 100644 --- a/v7/src/runtime/unxprm.scm +++ b/v7/src/runtime/unxprm.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.10 1991/01/26 03:21:15 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/unxprm.scm,v 1.11 1991/02/15 18:07:35 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -140,12 +140,8 @@ MIT in each case. |# (pathname-new-version pathname false))))))) (let ((result ((ucode-primitive file-touch) filename))) (if (string? result) - (error error-type:file - result - (error-irritant/noise #\newline) - (error-irritant/noise "within procedure") - (ucode-primitive file-touch)) - result)))) + (error:file-touch filename result)) + result))) (define (make-directory name) ((ucode-primitive directory-make) diff --git a/v7/src/runtime/version.scm b/v7/src/runtime/version.scm index 5bb563641..c9eb63156 100644 --- a/v7/src/runtime/version.scm +++ b/v7/src/runtime/version.scm @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.105 1991/01/26 03:24:00 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/version.scm,v 14.106 1991/02/15 18:07:40 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -45,7 +45,7 @@ MIT in each case. |# '())) (add-system! microcode-system) (add-event-receiver! event:after-restore snarf-microcode-version!) - (add-identification! "Runtime" 14 105)) + (add-identification! "Runtime" 14 106)) (define microcode-system) diff --git a/v7/src/runtime/where.scm b/v7/src/runtime/where.scm index 50d32372c..7ea61b499 100644 --- a/v7/src/runtime/where.scm +++ b/v7/src/runtime/where.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.8 1990/09/11 20:46:01 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/where.scm,v 14.9 1991/02/15 18:07:46 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 @@ -38,21 +38,24 @@ MIT in each case. |# (declare (usual-integrations)) (define (where #!optional environment) - (let ((wstate - (make-wstate - (list - (if (default-object? environment) - (nearest-repl/environment) - (->environment environment)))))) - (letter-commands - command-set - (cmdl-message/active - (lambda () - (show-current-frame wstate true) - (debugger-message - "You are now in the environment inspector. Type q to quit, ? for commands."))) - "Where-->" - wstate))) + (with-simple-restart 'CONTINUE "Return from WHERE." + (lambda () + (let ((wstate + (make-wstate + (list + (if (default-object? environment) + (nearest-repl/environment) + (->environment environment)))))) + (letter-commands + command-set + (cmdl-message/active + (lambda (cmdl) + cmdl + (show-current-frame wstate true) + (debugger-message + "You are now in the environment inspector. Type q to quit, ? for commands."))) + "Where-->" + wstate))))) (define-structure (wstate (conc-name wstate/)) diff --git a/v7/src/runtime/x11graph.scm b/v7/src/runtime/x11graph.scm index 9a04ee2c5..29ed56b56 100644 --- a/v7/src/runtime/x11graph.scm +++ b/v7/src/runtime/x11graph.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.6 1990/10/02 22:44:20 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/x11graph.scm,v 1.7 1991/02/15 18:07:54 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 @@ -267,7 +267,8 @@ MIT in each case. |# (x-graphics-device/process-events! device) (if (not (and (exact-nonnegative-integer? line-style) (< line-style 8))) - (error:illegal-datum line-style 'SET-LINE-STYLE)) + (error:wrong-type-argument line-style "graphics line style" + 'SET-LINE-STYLE)) (let ((xw (x-graphics-device/window device))) (if (zero? line-style) (x-graphics-set-line-style xw 0) diff --git a/v7/src/runtime/xeval.scm b/v7/src/runtime/xeval.scm index 1e9f99721..445fe3ec3 100644 --- a/v7/src/runtime/xeval.scm +++ b/v7/src/runtime/xeval.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/xeval.scm,v 1.2 1989/08/15 10:00:56 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v7/src/runtime/xeval.scm,v 1.3 1991/02/15 18:08:01 cph Exp $ -Copyright (c) 1989 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 @@ -110,7 +110,6 @@ MIT in each case. |# (CONDITIONAL ,rewrite/conditional) (DELAY ,rewrite/delay) (DISJUNCTION ,rewrite/disjunction) - (ERROR-COMBINATION ,rewrite/error-combination) (IN-PACKAGE ,rewrite/in-package) (LAMBDA ,rewrite/lambda) (SEQUENCE ,rewrite/sequence) @@ -213,14 +212,6 @@ MIT in each case. |# environment bound-names))) -(define (rewrite/error-combination expression environment bound-names) - (make-combination - (combination-operator expression) - (let ((operands (combination-operands expression))) - (list (rewrite/expression (car operands) environment bound-names) - (rewrite/expression (cadr operands) environment bound-names) - (caddr operands))))) - (define (rewrite/in-package expression environment bound-names) (make-in-package (rewrite/expression (in-package-environment expression) environment diff --git a/v8/src/runtime/global.scm b/v8/src/runtime/global.scm index d2d701ce9..c1eafc0ff 100644 --- a/v8/src/runtime/global.scm +++ b/v8/src/runtime/global.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.20 1990/11/14 13:24:16 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/global.scm,v 14.21 1991/02/15 18:05:37 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 @@ -246,20 +246,4 @@ MIT in each case. |# (per-bucket (-1+ index) accumulator) (per-symbol (cdr bucket) - (cons (car bucket) accumulator)))))))) - -(define (error:illegal-datum object #!optional operator-name) - (if (or (default-object? operator-name) (not operator-name)) - (error error-type:wrong-type-argument object) - (error error-type:wrong-type-argument object - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - operator-name))) - -(define (error:datum-out-of-range object #!optional operator-name) - (if (or (default-object? operator-name) (not operator-name)) - (error error-type:bad-range-argument object) - (error error-type:bad-range-argument object - (error-irritant/noise char:newline) - (error-irritant/noise "within procedure") - operator-name))) \ No newline at end of file + (cons (car bucket) accumulator)))))))) \ No newline at end of file diff --git a/v8/src/runtime/infstr.scm b/v8/src/runtime/infstr.scm index dcab0726e..36ad8d57f 100644 --- a/v8/src/runtime/infstr.scm +++ b/v8/src/runtime/infstr.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infstr.scm,v 1.3 1990/01/22 23:41:23 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infstr.scm,v 1.4 1991/02/15 18:05:45 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 @@ -161,35 +161,48 @@ MIT in each case. |# (define (dbg-label/name label) (cond ((dbg-label-2? label) (dbg-label-2/name label)) ((dbg-label-1? label) (dbg-label-1/name label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" 'DBG-LABEL/NAME)))) (define (set-dbg-label/name! label name) (cond ((dbg-label-1? label) (set-dbg-label-1/name! label name)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/NAME!)))) (define (dbg-label/offset label) (cond ((dbg-label-2? label) (dbg-label-2/offset label)) ((dbg-label-1? label) (dbg-label-1/offset label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/OFFSET)))) (define (dbg-label/external? label) (cond ((dbg-label-2? label) (dbg-label-2/external? label)) ((dbg-label-1? label) (dbg-label-1/external? label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/EXTERNAL?)))) (define (set-dbg-label/external?! label external?) (cond ((dbg-label-2? label) (set-dbg-label-2/external?! label external?)) ((dbg-label-1? label) (set-dbg-label-1/external?! label external?)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/EXTERNAL?!)))) (define (dbg-label/names label) (cond ((dbg-label-2? label) (dbg-label-2/names label)) ((dbg-label-1? label) (dbg-label-1/names label)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'DBG-LABEL/NAMES)))) (define (set-dbg-label/names! label names) (cond ((dbg-label-1? label) (set-dbg-label-1/names! label names)) - (else (error error-type:wrong-type-argument label)))) + (else + (error:wrong-type-argument label "debugging label" + 'SET-DBG-LABEL/NAMES!)))) (define-structure (dbg-label-1 (named diff --git a/v8/src/runtime/infutl.scm b/v8/src/runtime/infutl.scm index b45db0f44..2530078c1 100644 --- a/v8/src/runtime/infutl.scm +++ b/v8/src/runtime/infutl.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.19 1990/11/15 19:07:18 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/infutl.scm,v 1.20 1991/02/15 18:05:49 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 @@ -90,7 +90,7 @@ MIT in each case. |# (and (file-exists? filename) (call-with-current-continuation (lambda (k) - (bind-condition-handler (list error-type:fasload) + (bind-condition-handler (list condition-type:fasload-band) (lambda (condition) condition (k false)) (lambda () (fasload filename true))))))) diff --git a/v8/src/runtime/load.scm b/v8/src/runtime/load.scm index e0605918a..3312b495d 100644 --- a/v8/src/runtime/load.scm +++ b/v8/src/runtime/load.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.19 1990/11/19 19:33:01 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/load.scm,v 14.20 1991/02/15 18:06:13 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 @@ -183,7 +183,7 @@ MIT in each case. |# (load/default-find-pathname-with-type pathname default-types))))) (if (not truename) - (error error-type:open-file pathname)) + (error:open-file pathname)) truename))) (define (search-types-in-order pathname default-types) diff --git a/v8/src/runtime/make.scm b/v8/src/runtime/make.scm index 8b1131d18..0e31306ae 100644 --- a/v8/src/runtime/make.scm +++ b/v8/src/runtime/make.scm @@ -1,8 +1,8 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.25 1990/11/15 23:27:03 cph Rel $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/make.scm,v 14.26 1991/02/15 18:06:25 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 @@ -304,6 +304,8 @@ MIT in each case. |# (RUNTIME HASH) (RUNTIME RANDOM-NUMBER) (RUNTIME RECORD) + (RUNTIME ERROR-HANDLER) + (RUNTIME MICROCODE-ERRORS) ;; Microcode data structures (RUNTIME HISTORY) (RUNTIME LAMBDA-ABSTRACTION) @@ -340,8 +342,6 @@ MIT in each case. |# (RUNTIME PRETTY-PRINTER) (RUNTIME EXTENDED-SCODE-EVAL) ;; REP Loops - (RUNTIME ERROR-HANDLER) - (RUNTIME MICROCODE-ERRORS) (RUNTIME INTERRUPT-HANDLER) (RUNTIME GC-STATISTICS) (RUNTIME REP) diff --git a/v8/src/runtime/runtime.pkg b/v8/src/runtime/runtime.pkg index aa467a11a..38f7bcee7 100644 --- a/v8/src/runtime/runtime.pkg +++ b/v8/src/runtime/runtime.pkg @@ -1,6 +1,6 @@ #| -*-Scheme-*- -$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.88 1991/01/26 03:23:44 cph Exp $ +$Header: /Users/cph/tmp/foo/mit-scheme/mit-scheme/v8/src/runtime/runtime.pkg,v 14.89 1991/02/15 18:06:51 cph Exp $ Copyright (c) 1988-91 Massachusetts Institute of Technology @@ -527,53 +527,97 @@ MIT in each case. |# (files "error") (parent ()) (export () + abort + access-condition bind-condition-handler - cmdl-message/error - condition-type/generalizations + bind-restart + bound-restarts + break-on-signals + condition-accessor + condition-constructor + condition-predicate + condition-signaller condition-type/error? + condition-type/field-names + condition-type/generalizations + condition-type/get condition-type/properties - condition-type/reporter + condition-type/put! + condition-type:arithmetic-error + condition-type:bad-range-argument + condition-type:cell-error + condition-type:control-error + condition-type:datum-out-of-range + condition-type:derived-port-error + condition-type:divide-by-zero condition-type:error + condition-type:file-error + condition-type:file-touch-error + condition-type:floating-point-overflow + condition-type:floating-point-underflow + condition-type:illegal-datum + condition-type:no-such-restart + condition-type:open-file-error + condition-type:port-error + condition-type:serious-condition + condition-type:simple-condition + condition-type:simple-error + condition-type:simple-warning + condition-type:unassigned-variable + condition-type:unbound-variable + condition-type:variable-error + condition-type:warning + condition-type:wrong-number-of-arguments + condition-type:wrong-type-argument + condition-type:wrong-type-datum condition-type? condition/continuation condition/error? - condition/generalizations - condition/internal? - condition/irritants - condition/message + condition/get condition/properties - condition/report-string - condition/reporter + condition/put! + condition/restarts condition/type - condition/write-report condition? - error-condition - error-continuation - error-irritant + continue + error error-irritant/noise - error-irritant/noise-value - error-irritant/noise? - error-irritants - error-irritants/sans-noise - error-message - error-type:vanilla - error-type? - error? + error:bad-range-argument + error:datum-out-of-range + error:derived-port + error:divide-by-zero + error:file-touch + error:no-such-restart + error:open-file + error:wrong-number-of-arguments + error:wrong-type-argument + error:wrong-type-datum + find-restart format-error-message - guarantee-condition - guarantee-condition-type + invoke-restart + invoke-restart-interactively make-condition make-condition-type - make-error-type + muffle-warning + restart/effector + restart/get + restart/name + restart/properties + restart/put! + restart? signal-condition - signal-error standard-error-handler - warn) - (export (runtime rep) - default/error-handler - hook/error-handler) - (export (runtime emacs-interface) - hook/error-decision) + standard-error-hook + standard-warning-handler + standard-warning-hook + store-value + use-value + warn + with-simple-restart + write-condition-report + write-restart-report) + (export (runtime microcode-errors) + write-operator) (initialization (initialize-package!))) (define-package (runtime event-distributor) @@ -1062,18 +1106,27 @@ MIT in each case. |# (files "uerror") (parent (runtime error-handler)) (export () - error-type:anomalous - error-type:bad-range-argument - error-type:failed-argument-coercion - error-type:fasdump - error-type:fasload - error-type:file - error-type:illegal-argument - error-type:open-file - error-type:premature-write-termination - error-type:random-internal - error-type:wrong-type-argument - microcode-error-type) + condition-type:anomalous-microcode-error + condition-type:compiled-code-error + condition-type:fasdump-environment + condition-type:fasl-file-bad-data + condition-type:fasl-file-compiled-mismatch + condition-type:fasl-file-too-big + condition-type:fasload-band + condition-type:fasload-error + condition-type:hardware-trap + condition-type:impurify-object-too-large + condition-type:inapplicable-object + condition-type:microcode-asynchronous + condition-type:out-of-file-handles + condition-type:primitive-io-error + condition-type:primitive-procedure-error + condition-type:system-call-error + condition-type:unimplemented-primitive + condition-type:unimplemented-primitive-for-os + condition-type:unlinkable-variable + condition-type:user-microcode-reset + condition-type:wrong-arity-primitives) (initialization (initialize-package!))) (define-package (runtime microcode-tables) @@ -1422,6 +1475,7 @@ MIT in each case. |# pty-master-send-signal pty-master-stop) (export (runtime generic-input) + bind-port-for-errors input-buffer/buffered-chars input-buffer/channel input-buffer/char-ready? @@ -1438,6 +1492,7 @@ MIT in each case. |# input-buffer/size make-input-buffer) (export (runtime generic-output) + bind-port-for-errors make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1447,6 +1502,7 @@ MIT in each case. |# output-buffer/size output-buffer/write-string-block) (export (runtime file-input) + bind-port-for-errors file-length file-open-input-channel input-buffer/chars-remaining @@ -1457,6 +1513,7 @@ MIT in each case. |# file-open-output-channel make-output-buffer) (export (runtime console-input) + bind-port-for-errors channel-type=file? input-buffer/buffer-contents input-buffer/buffered-chars @@ -1471,6 +1528,7 @@ MIT in each case. |# make-input-buffer tty-input-channel) (export (runtime console-output) + bind-port-for-errors make-output-buffer output-buffer/buffered-chars output-buffer/channel @@ -1542,15 +1600,12 @@ MIT in each case. |# abort->nearest abort->previous abort->top-level - abort-to-nearest-driver - abort-to-previous-driver - abort-to-top-level-driver + bkpt breakpoint breakpoint-procedure cmdl-interrupt/abort-nearest cmdl-interrupt/abort-previous cmdl-interrupt/abort-top-level - cmdl-interrupt/abort-top-level/reset? cmdl-interrupt/breakpoint cmdl-message/active cmdl-message/append @@ -1559,23 +1614,23 @@ MIT in each case. |# cmdl-message/strings cmdl-message/value cmdl/base - cmdl/continuation cmdl/driver cmdl/input-port cmdl/level cmdl/output-port cmdl/parent - cmdl/proceed-continuation cmdl/state cmdl? - current-proceed-continuation ge gst in initial-top-level-repl make-cmdl nearest-cmdl + nearest-cmdl/input-port + nearest-cmdl/output-port nearest-repl + nearest-repl/condition nearest-repl/environment nearest-repl/syntax-table out @@ -1584,6 +1639,7 @@ MIT in each case. |# prompt-for-command-char prompt-for-confirmation prompt-for-expression + prompt-for-evaluated-expression push-cmdl push-repl re @@ -1599,7 +1655,7 @@ MIT in each case. |# repl/reader-history repl/syntax-table repl? - set-cmdl/continuation! + restart set-cmdl/input-port! set-cmdl/output-port! set-cmdl/state! @@ -1608,16 +1664,16 @@ MIT in each case. |# set-repl/prompt! set-repl/reader-history! set-repl/syntax-table! + ve with-cmdl/input-port - with-cmdl/output-port - with-proceed-point - with-standard-proceed-point) + with-cmdl/output-port) (export (runtime load) hook/repl-eval hook/repl-write) (export (runtime emacs-interface) hook/cmdl-message hook/cmdl-prompt + hook/error-decision hook/prompt-for-confirmation hook/prompt-for-expression hook/read-command-char @@ -1675,6 +1731,7 @@ MIT in each case. |# in-package-expression in-package? intern + interned-symbol? make-absolute-reference make-access make-assignment @@ -1702,6 +1759,7 @@ MIT in each case. |# symbol-hash-mod symbol? the-environment? + uninterned-symbol? variable-components variable-name variable?) -- 2.25.1