#| -*-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
;;; 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)))
(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)))))))))
\f
;;;; Primitive Advisors
(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))
#| -*-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
(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)
(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)
(cond ((int:positive? n) (0<n n))
((int:negative? n) (cons #\- (0<n (int:negate n))))
(else (list #\0)))))
- (error:illegal-datum n 'NUMBER->STRING)))
+ (error:wrong-type-argument n false 'NUMBER->STRING)))
\f
(declare (integrate-operator rat:rational?))
(define (rat:rational? object)
(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)
(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)))
((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)
(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
(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)
;; 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)
((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)
(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)))
(lambda (q)
(if (rat:rational? q)
q
- (error:illegal-datum q 'INEXACT->EXACT)))))
+ (error:wrong-type-argument q false 'INEXACT->EXACT)))))
\f
(let-syntax
((define-standard-binary
(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
(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
((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)
(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)
((real:real? z)
z)
(else
- (error:illegal-datum z 'CONJUGATE))))
+ (error:wrong-type-argument z false 'CONJUGATE))))
(define (complex:/ z1 z2)
(if (recnum? z1)
(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)
(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
#| -*-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
;; 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)))
(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)
#| -*-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
(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))
(define (standard-exit-command state)
state ;ignore
- (proceed))
+ (continue)
+ (debugger-failure "Can't exit; use a restart command instead."))
\f
(define (initialize-package!)
(set! hook/leaving-command-loop default/leaving-command-loop))
(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
#| -*-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
(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)))))
+\f
(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))
history-state
expression
subexpression
- environment-list)
+ environment-list
+ condition)
(define (dstate/reduction dstate)
(nth-reduction (dstate/reductions dstate)
"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
(define (command/enter-where dstate)
(with-current-environment dstate debug/where))
\f
-;;;; 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)))
\f
;;;; Advanced hacking commands
#| -*-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
((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
#| -*-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
(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)
(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]")))
(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)
(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)))
(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)
(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)
(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)
(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)
#| -*-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
(declare (usual-integrations))
\f
-(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))))))
-\f
-(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))))
-\f
-;;;; 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)))
-\f
-;;;; 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")
-\f
;;;; 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-type<? x y)
- (< (condition-type/index x) (condition-type/index y)))
+(define (make-condition-type name generalization field-names reporter)
+ (if generalization
+ (guarantee-condition-type generalization 'MAKE-CONDITION-TYPE))
+ (guarantee-list-of-symbols field-names 'MAKE-CONDITION-TYPE)
+ (let ((type
+ (%make-condition-type
+ (cond ((string? name) (string-copy name))
+ ((symbol? name) (symbol->string 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))
\f
-(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<? (car x) (car y))
- (cons (car y) (generalizations/union x (cdr y))))
- (else
- (cons (car x) (generalizations/union (cdr x) y)))))
+(define (%condition-type/field-index type field-name operator)
+ (let ((association (assq field-name (%condition-type/field-indexes type))))
+ (if (not association)
+ (error:bad-range-argument field-name operator))
+ (cdr association)))
-(define (generalizations/intersect? x y)
- (cond ((or (null? x) (null? y)) false)
- ((eq? (car x) (car y)) true)
- ((condition-type<? (car x) (car y))
- (generalizations/intersect? x (cdr y)))
- (else
- (generalizations/intersect? (cdr x) y))))
+(define (condition-type/field-names type)
+ (guarantee-condition-type type 'CONDITION-TYPE/FIELD-NAMES)
+ (map car (%condition-type/field-indexes type)))
-(define (make-error-type generalizations reporter)
- (make-condition-type
- (if (there-exists? generalizations condition-type/error?)
- generalizations
- (cons condition-type:error generalizations))
- reporter))
+(define (condition-type/generalizations type)
+ (guarantee-condition-type type 'CONDITION-TYPE/GENERALIZATIONS)
+ (list-copy (cdr (%condition-type/generalizations type))))
-(define (error-type? object)
- (and (condition-type? object)
- (condition-type/error? object)))
+(define (condition-type/properties type)
+ (guarantee-condition-type type 'CONDITION-TYPE/PROPERTIES)
+ (%condition-type/properties type))
-(define condition-type:error)
-(define condition-type:microcode-asynchronous)
-(define condition-type:hardware-trap)
-(define condition-type:user-microcode-reset)
+(define (condition-type/put! type key datum)
+ (1d-table/put! (condition-type/properties type) key datum))
+
+(define (condition-type/get type key)
+ (1d-table/get (condition-type/properties type) key false))
\f
;;;; Condition Instances
(define-structure (condition
- (constructor %make-condition (type irritants continuation))
- (conc-name condition/))
+ (conc-name %condition/)
+ (constructor %make-condition (type continuation restarts))
+ (print-procedure
+ (unparser/standard-method 'CONDITION
+ (lambda (state condition)
+ (unparse-string state
+ (%condition-type/name
+ (%condition/type condition)))))))
(type false read-only true)
- (irritants false read-only true)
(continuation false read-only true)
+ (restarts false read-only true)
+ (field-values (make-vector (%condition-type/number-of-fields type) false)
+ read-only true)
(properties (make-1d-table) read-only true))
-(define (make-condition type irritants continuation)
- (guarantee-condition-type type)
- (if (not (list? irritants))
- (error "Illegal condition irritants" irritants))
- (guarantee-continuation continuation)
- (%make-condition type irritants continuation))
+(define (make-condition type continuation restarts field-alist)
+ (guarantee-condition-type type 'MAKE-CONDITION)
+ (guarantee-continuation continuation 'MAKE-CONDITION)
+ (guarantee-keyword-association-list field-alist 'MAKE-CONDITION)
+ (let ((condition
+ (%make-condition type
+ continuation
+ (%restarts-argument restarts 'MAKE-CONDITION))))
+ (let ((field-values (%condition/field-values condition)))
+ (do ((alist field-alist (cddr alist)))
+ ((null? alist))
+ (vector-set! field-values
+ (%condition-type/field-index type (car alist)
+ 'MAKE-CONDITION)
+ (cadr alist))))
+ condition))
-(define (guarantee-condition object)
- (if (not (condition? object)) (error "Illegal condition" object))
- object)
+(define (condition-constructor type field-names)
+ (guarantee-condition-type type 'CONDITION-CONSTRUCTOR)
+ (guarantee-list-of-symbols field-names 'CONDITION-CONSTRUCTOR)
+ (let ((indexes
+ (map (lambda (field-name)
+ (%condition-type/field-index type field-name
+ 'CONDITION-CONSTRUCTOR))
+ field-names)))
+ (letrec
+ ((constructor
+ (lambda (continuation restarts . field-values)
+ (guarantee-continuation continuation constructor)
+ (let ((condition
+ (%make-condition type
+ continuation
+ (%restarts-argument restarts
+ constructor))))
+ (let ((values (%condition/field-values condition)))
+ (do ((i indexes (cdr i))
+ (v field-values (cdr v)))
+ ((or (null? i) (null? v))
+ (if (not (and (null? i) (null? v)))
+ (error:wrong-number-of-arguments
+ constructor
+ (+ (length indexes) 1)
+ (cons continuation field-values))))
+ (vector-set! values (car i) (car v))))
+ condition))))
+ constructor)))
+
+(define-integrable (%restarts-argument restarts operator)
+ (cond ((eq? 'BOUND-RESTARTS restarts)
+ *bound-restarts*)
+ ((condition? restarts)
+ (%condition/restarts restarts))
+ (else
+ (guarantee-restarts restarts operator)
+ (list-copy restarts))))
+\f
+(define (condition-predicate type)
+ (guarantee-condition-type type 'CONDITION-PREDICATE)
+ (lambda (object)
+ (and (condition? object)
+ (eq? type (%condition/type object)))))
+
+(define (condition-accessor type field-name)
+ (guarantee-condition-type type 'CONDITION-ACCESSOR)
+ (guarantee-symbol field-name 'CONDITION-ACCESSOR)
+ (let ((type-description
+ (string-append "condition of type " (write-to-string type)))
+ (index
+ (%condition-type/field-index type
+ field-name
+ 'CONDITION-ACCESSOR)))
+ (lambda (condition)
+ (if (not (and (condition? condition)
+ (eq? type (%condition/type condition))))
+ (error:wrong-type-argument condition type-description
+ 'CONDITION-ACCESSOR))
+ (vector-ref (%condition/field-values condition) index))))
+
+(define (access-condition condition field-name)
+ (guarantee-condition condition 'ACCESS-CONDITION)
+ ((condition-accessor (%condition/type condition) field-name) condition))
+
+(define (condition/type condition)
+ (guarantee-condition condition 'CONDITION/TYPE)
+ (%condition/type condition))
+
+(define (condition/continuation condition)
+ (guarantee-condition condition 'CONDITION/CONTINUATION)
+ (%condition/continuation condition))
+
+(define (condition/restarts condition)
+ (guarantee-condition condition 'CONDITION/RESTARTS)
+ (list-copy (%condition/restarts condition)))
+
+(define (condition/properties condition)
+ (guarantee-condition condition 'CONDITION/PROPERTIES)
+ (%condition/properties condition))
+
+(define (condition/put! condition key datum)
+ (1d-table/put! (condition/properties condition) key datum))
+
+(define (condition/get condition key)
+ (1d-table/get (condition/properties condition) key false))
+
+(define (write-condition-report condition port)
+ (guarantee-condition condition 'WRITE-CONDITION-REPORT)
+ (guarantee-output-port port 'WRITE-CONDITION-REPORT)
+ ((%condition-type/reporter (%condition/type condition)) condition port))
+\f
+;;;; Restarts
+
+(define *bound-restarts* '())
+
+(define-structure (restart
+ (conc-name %restart/)
+ (constructor %make-restart (name reporter effector))
+ (print-procedure
+ (unparser/standard-method 'RESTART
+ (lambda (state restart)
+ (let ((name (%restart/name restart)))
+ (if name
+ (unparse-object state name)
+ (unparse-string state "(anonymous)")))))))
+ (name false read-only true)
+ (reporter false read-only true)
+ (effector false read-only true)
+ (properties (make-1d-table) read-only true))
-(define-integrable (condition/internal? condition)
- ;; For future expansion.
- condition
- false)
+(define (bind-restart name reporter effector receiver)
+ (if name (guarantee-symbol name 'BIND-RESTART))
+ (if (not (or (string? reporter) (procedure-of-arity? reporter 1)))
+ (error:wrong-type-argument reporter "restart reporter" 'BIND-RESTART))
+ (if (not (procedure? effector))
+ (error:wrong-type-argument effector "restart effector" 'BIND-RESTART))
+ (let ((restart (%make-restart name reporter effector)))
+ (fluid-let ((*bound-restarts* (cons restart *bound-restarts*)))
+ (receiver restart))))
+
+(define (with-simple-restart name reporter thunk)
+ (call-with-current-continuation
+ (lambda (continuation)
+ (bind-restart name reporter (lambda () (continuation unspecific))
+ (lambda (restart)
+ restart
+ (thunk))))))
+
+(define (restart/name restart)
+ (guarantee-restart restart 'RESTART/NAME)
+ (%restart/name restart))
+
+(define (restart/effector restart)
+ (guarantee-restart restart 'RESTART/EFFECTOR)
+ (%restart/effector restart))
+
+(define (restart/properties restart)
+ (guarantee-restart restart 'RESTART/PROPERTIES)
+ (%restart/properties restart))
+
+(define (restart/put! restart key datum)
+ (1d-table/put! (restart/properties restart) key datum))
+
+(define (restart/get restart key)
+ (1d-table/get (restart/properties restart) key false))
+
+(define (write-restart-report restart port)
+ (guarantee-restart restart 'WRITE-RESTART-REPORT)
+ (guarantee-output-port port 'WRITE-RESTART-REPORT)
+ (let ((reporter (%restart/reporter restart)))
+ (if (string? reporter)
+ (write-string reporter port)
+ (reporter port))))
+\f
+(define (invoke-restart restart . arguments)
+ (guarantee-restart restart 'INVOKE-RESTART)
+ (apply (%restart/effector restart) arguments))
+
+(define (invoke-restart-interactively restart)
+ (guarantee-restart restart 'INVOKE-RESTART-INTERACTIVELY)
+ (let ((effector (%restart/effector restart))
+ (interactive
+ (1d-table/get (%restart/properties restart) 'INTERACTIVE false)))
+ (if (not interactive)
+ (effector)
+ (with-values interactive effector))))
+
+(define (bound-restarts)
+ (let loop ((restarts *bound-restarts*))
+ (if (null? restarts)
+ '()
+ (cons (car restarts) (loop (cdr restarts))))))
+
+(define (%find-restart name restarts)
+ (let loop ((restarts restarts))
+ (and (not (null? restarts))
+ (if (eq? name (%restart/name (car restarts)))
+ (car restarts)
+ (loop (cdr restarts))))))
+
+(define-macro (restarts-default restarts name)
+ ;; This is a macro because DEFAULT-OBJECT? is.
+ `(COND ((OR (DEFAULT-OBJECT? ,restarts)
+ (EQ? 'BOUND-RESTARTS ,restarts))
+ *BOUND-RESTARTS*)
+ ((CONDITION? ,restarts)
+ (%CONDITION/RESTARTS ,restarts))
+ (ELSE
+ (GUARANTEE-RESTARTS ,restarts ',name)
+ ,restarts)))
+
+(define (find-restart name #!optional restarts)
+ (guarantee-symbol name 'FIND-RESTART)
+ (%find-restart name (restarts-default restarts 'FIND-RESTART)))
+
+(define (abort #!optional restarts)
+ (let ((restart (%find-restart 'ABORT (restarts-default restarts 'ABORT))))
+ (if (not restart)
+ (error:no-such-restart 'ABORT))
+ ((%restart/effector restart))))
+
+(define (continue #!optional restarts)
+ (let ((restart
+ (%find-restart 'CONTINUE (restarts-default restarts 'CONTINUE))))
+ (if restart
+ ((%restart/effector restart)))))
+
+(define (muffle-warning #!optional restarts)
+ (let ((restart
+ (%find-restart 'MUFFLE-WARNING
+ (restarts-default restarts 'MUFFLE-WARNING))))
+ (if (not restart)
+ (error:no-such-restart 'MUFFLE-WARNING))
+ ((%restart/effector restart))))
+
+(define (store-value datum #!optional restarts)
+ (let ((restart
+ (%find-restart 'STORE-VALUE
+ (restarts-default restarts 'STORE-VALUE))))
+ (if restart
+ ((%restart/effector restart) datum))))
+
+(define (use-value datum #!optional restarts)
+ (let ((restart
+ (%find-restart 'USE-VALUE
+ (restarts-default restarts 'USE-VALUE))))
+ (if restart
+ ((%restart/effector restart) datum))))
+\f
+;;;; Condition Signalling and Handling
-(define-integrable (condition/generalizations condition)
- (condition-type/generalizations (condition/type condition)))
+(define handler-frames false)
+(define break-on-signals-types '())
-(define-integrable (condition/error? condition)
- (condition-type/error? (condition/type condition)))
+(define-structure (handler-frame
+ (type vector)
+ (conc-name handler-frame/))
+ (types false read-only true)
+ (handler false read-only true)
+ (next false read-only true))
-(define-integrable (condition/reporter condition)
- (condition-type/reporter (condition/type condition)))
+(define (bind-condition-handler types handler thunk)
+ (guarantee-condition-types types 'BIND-CONDITION-HANDLER)
+ (guarantee-condition-handler handler 'BIND-CONDITION-HANDLER)
+ (fluid-let ((handler-frames
+ (make-handler-frame types handler handler-frames)))
+ (thunk)))
+
+(define (break-on-signals types)
+ (guarantee-condition-types types 'BREAK-ON-SIGNALS)
+ (set! break-on-signals-types types)
+ unspecific)
-(define (error? object)
- (and (condition? object)
- (condition/error? object)))
+(define (signal-condition condition)
+ (guarantee-condition condition 'SIGNAL-CONDITION)
+ (let ((generalizations
+ (%condition-type/generalizations (%condition/type condition))))
+ (let ((intersect-generalizations?
+ (lambda (types)
+ (let outer ((type (car types)) (types (cdr types)))
+ (let inner ((generalizations generalizations))
+ (if (null? generalizations)
+ (and (not (null? types))
+ (outer (car types) (cdr types)))
+ (or (eq? type (car generalizations))
+ (inner (cdr generalizations)))))))))
+ (if (let ((types break-on-signals-types))
+ (and (not (null? types))
+ (intersect-generalizations? types)))
+ (bkpt "BKPT entered because of BREAK-ON-SIGNALS:" condition))
+ (let loop ((frame handler-frames))
+ (if frame
+ (let ((next (handler-frame/next frame)))
+ (if (let ((types (handler-frame/types frame)))
+ (or (null? types)
+ (intersect-generalizations? types)))
+ (fluid-let ((handler-frames next))
+ ((handler-frame/handler frame) condition)))
+ (loop next)))))))
+\f
+;;;; Standard Condition Signallers
-(define (condition/write-report condition #!optional port)
- ((condition/reporter condition)
- condition
- (if (default-object? port)
- (current-output-port)
- (guarantee-output-port port))))
+(define (error datum . arguments)
+ (signal-simple datum arguments make-simple-error standard-error-handler))
-(define (condition/report-string condition)
- (with-output-to-string
+(define (warn datum . arguments)
+ (with-simple-restart 'MUFFLE-WARNING "Ignore warning."
(lambda ()
- ((condition/reporter condition) condition (current-output-port)))))
+ (signal-simple datum arguments
+ make-simple-warning standard-warning-handler))))
+
+(define (signal-simple datum arguments make-simple-condition default-handler)
+ (if (condition? datum)
+ (begin
+ (signal-condition datum)
+ (default-handler datum))
+ (call-with-current-continuation
+ (lambda (continuation)
+ (let ((condition
+ (if (condition-type? datum)
+ (make-condition datum
+ continuation
+ 'BOUND-RESTARTS
+ arguments)
+ (make-simple-condition continuation
+ 'BOUND-RESTARTS
+ datum
+ arguments))))
+ (begin
+ (signal-condition condition)
+ (default-handler condition)))))))
+
+(define (standard-error-handler condition)
+ (let ((hook standard-error-hook))
+ (if hook
+ (fluid-let ((standard-error-hook false))
+ (hook condition))))
+ (push-repl false condition "Error->"))
+
+(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)))))))
+\f
+;;;; 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)))
\f
-;;;; 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))))
+\f
+ (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)))))
+\f
+ (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))))
+\f
+ (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))))
+\f
+ (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)
+\f
+;;;; 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))
+\f
+(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
#| -*-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
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"))
\f
(define pure-space-queue)
(define constant-space-queue)
(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)))))))
\f
;;;; User Primitives
#| -*-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
(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
#| -*-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
(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))))
\f
;;;; Common Hash Table Constructors
#| -*-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
(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
#| -*-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
(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)))))))
#| -*-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
(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)
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)
#| -*-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
(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))
#| -*-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
(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))
\f
;;;; 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)
#| -*-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
((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)
#| -*-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
(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)
#| -*-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
(RUNTIME HASH)
(RUNTIME RANDOM-NUMBER)
(RUNTIME RECORD)
+ (RUNTIME ERROR-HANDLER)
+ (RUNTIME MICROCODE-ERRORS)
;; Microcode data structures
(RUNTIME HISTORY)
(RUNTIME LAMBDA-ABSTRACTION)
(RUNTIME PRETTY-PRINTER)
(RUNTIME EXTENDED-SCODE-EVAL)
;; REP Loops
- (RUNTIME ERROR-HANDLER)
- (RUNTIME MICROCODE-ERRORS)
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
#| -*-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
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)
#| -*-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
(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)
(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)))))
#| -*-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
((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 ()
#| -*-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
(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
(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)
(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)
(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))))))
\f
(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)
(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)
(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
(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
(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
#| -*-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
(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)
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))
\f
;;;; Command Loops
(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*)
(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
;;;; Messages
(define hook/cmdl-prompt)
-
(define (default/cmdl-prompt cmdl prompt)
(with-output-port-cooked cmdl
(lambda (output-port)
(hook/cmdl-message cmdl string))
(define hook/cmdl-message)
-
(define (default/cmdl-message cmdl string)
(with-output-port-cooked cmdl
(lambda (output-port)
(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)
\f
;;;; 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)))))
-\f
-;;;; 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>"))))
\f
;;;; 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
s-expression
(repl/environment repl)
(repl/syntax-table repl))))))
-
+\f
+(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)))))))
+\f
(define (repl? object)
(and (cmdl? object)
(repl-state? (cmdl/state object))))
(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)))
(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)))
(define-integrable (set-repl/printer-history! repl printer-history)
(set-repl-state/printer-history! (cmdl/state repl) printer-history))
-\f
+
(define (repl/parent repl)
(skip-non-repls (cmdl/parent repl)))
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)))
\f
;;;; Hooks
(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))
(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))))
(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))))))
\f
;;;; History
(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)))
\f
;;; User Interface Stuff
-(define user-repl-environment)
-(define user-repl-syntax-table)
-
(define (pe)
(let ((environment (nearest-repl/environment)))
(let ((package (environment->package environment)))
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)
(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)
(repl-history/read (repl/printer-history (nearest-repl))
(- (if (default-object? index) 1 index) 1)))
\f
+(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)))
+\f
;;;; Prompting
(define (prompt-for-command-char prompt #!optional cmdl)
(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)
#| -*-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
(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)
(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)
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?
input-buffer/size
make-input-buffer)
(export (runtime generic-output)
+ bind-port-for-errors
make-output-buffer
output-buffer/buffered-chars
output-buffer/channel
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
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
make-input-buffer
tty-input-channel)
(export (runtime console-output)
+ bind-port-for-errors
make-output-buffer
output-buffer/buffered-chars
output-buffer/channel
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
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
prompt-for-command-char
prompt-for-confirmation
prompt-for-expression
+ prompt-for-evaluated-expression
push-cmdl
push-repl
re
repl/reader-history
repl/syntax-table
repl?
- set-cmdl/continuation!
+ restart
set-cmdl/input-port!
set-cmdl/output-port!
set-cmdl/state!
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
in-package-expression
in-package?
intern
+ interned-symbol?
make-absolute-reference
make-access
make-assignment
symbol-hash-mod
symbol?
the-environment?
+ uninterned-symbol?
variable-components
variable-name
variable?)
#| -*-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
;;;; 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)))
(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)
#| -*-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
(&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)))
,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
#| -*-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
(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)
#| -*-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
(declare (usual-integrations))
\f
-(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)))))
\f
-(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))))
\f
-;;;; 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))))))
+\f
+;;;; 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)
+\f
+;;;; 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)))
+\f
+(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))
+\f
+;;;; 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))))))))
+\f
+(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)))))))
+\f
+;;;; 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)
+\f
+;;;; 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))))))))
+\f
+(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)))
+\f
+(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))))))))
\f
-;;;; 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)))))))))
\f
-(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)))))))
\f
-(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))))))))
\f
-(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
#| -*-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
(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)
(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)))
(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))
\f
;;;; Unsyntax Quanta
(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
`(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)
(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)))))))
\f
(define (unsyntax/fluid-let names values body if-malformed)
(combination-components body
#| -*-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
(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)
#| -*-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
'()))
(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)
#| -*-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
(declare (usual-integrations))
\f
(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/))
#| -*-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
(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)
#| -*-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
(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)
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
#| -*-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
(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
#| -*-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
(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
#| -*-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
(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)))))))
#| -*-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
(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)
#| -*-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
(RUNTIME HASH)
(RUNTIME RANDOM-NUMBER)
(RUNTIME RECORD)
+ (RUNTIME ERROR-HANDLER)
+ (RUNTIME MICROCODE-ERRORS)
;; Microcode data structures
(RUNTIME HISTORY)
(RUNTIME LAMBDA-ABSTRACTION)
(RUNTIME PRETTY-PRINTER)
(RUNTIME EXTENDED-SCODE-EVAL)
;; REP Loops
- (RUNTIME ERROR-HANDLER)
- (RUNTIME MICROCODE-ERRORS)
(RUNTIME INTERRUPT-HANDLER)
(RUNTIME GC-STATISTICS)
(RUNTIME REP)
#| -*-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
(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)
(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)
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?
input-buffer/size
make-input-buffer)
(export (runtime generic-output)
+ bind-port-for-errors
make-output-buffer
output-buffer/buffered-chars
output-buffer/channel
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
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
make-input-buffer
tty-input-channel)
(export (runtime console-output)
+ bind-port-for-errors
make-output-buffer
output-buffer/buffered-chars
output-buffer/channel
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
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
prompt-for-command-char
prompt-for-confirmation
prompt-for-expression
+ prompt-for-evaluated-expression
push-cmdl
push-repl
re
repl/reader-history
repl/syntax-table
repl?
- set-cmdl/continuation!
+ restart
set-cmdl/input-port!
set-cmdl/output-port!
set-cmdl/state!
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
in-package-expression
in-package?
intern
+ interned-symbol?
make-absolute-reference
make-access
make-assignment
symbol-hash-mod
symbol?
the-environment?
+ uninterned-symbol?
variable-components
variable-name
variable?)
projects / mit-scheme.git / commitdiff