96 lines
2.6 KiB
Factor
96 lines
2.6 KiB
Factor
! Copyright (C) 2004, 2006 Slava Pestov.
|
|
! See http://factorcode.org/license.txt for BSD license.
|
|
USING: arrays generic hashtables help inspector io kernel
|
|
kernel-internals math namespaces parser prettyprint sequences
|
|
sequences-internals strings styles vectors words ;
|
|
IN: errors
|
|
|
|
PREDICATE: array kernel-error ( obj -- ? )
|
|
dup first \ kernel-error eq? swap second 0 18 between? and ;
|
|
|
|
GENERIC: error. ( error -- )
|
|
GENERIC: error-help ( error -- topic )
|
|
|
|
M: object error. . ;
|
|
M: object error-help drop f ;
|
|
|
|
M: tuple error. describe ;
|
|
M: tuple error-help class ;
|
|
|
|
M: string error. print ;
|
|
|
|
SYMBOL: restarts
|
|
|
|
: :s error-continuation get continuation-data stack. ;
|
|
: :r error-continuation get continuation-retain stack. ;
|
|
: :c error-continuation get continuation-call callstack. ;
|
|
: :get error-continuation get continuation-name hash-stack ;
|
|
: :res restarts get nth first3 continue-with ;
|
|
|
|
: (:help-multi)
|
|
"This error has multiple delegates:" print help-outliner ;
|
|
|
|
: (:help-none)
|
|
drop "No help for this error. " print ;
|
|
|
|
: :help ( -- )
|
|
error get delegates [ error-help ] map [ ] subset
|
|
{
|
|
{ [ dup empty? ] [ (:help-none) ] }
|
|
{ [ dup length 1 = ] [ first help ] }
|
|
{ [ t ] [ (:help-multi) ] }
|
|
} cond ;
|
|
|
|
: (debug-help) ( string quot -- )
|
|
<input> write-object terpri ;
|
|
|
|
: restart. ( restart n -- )
|
|
[ [ # " :res " % first % ] "" make ] keep
|
|
[ :res ] curry (debug-help) ;
|
|
|
|
: restarts. ( -- )
|
|
restarts get dup empty? [
|
|
drop
|
|
] [
|
|
terpri
|
|
"The following restarts are available:" print
|
|
terpri
|
|
dup length [ restart. ] 2each
|
|
] if ;
|
|
|
|
: debug-help ( -- )
|
|
terpri
|
|
"Debugger commands:" print
|
|
terpri
|
|
":help - documentation for this error" [ :help ] (debug-help)
|
|
":s - data stack at exception time" [ :s ] (debug-help)
|
|
":r - retain stack at exception time" [ :r ] (debug-help)
|
|
":c - call stack at exception time" [ :c ] (debug-help)
|
|
":get ( var -- value ) accesses variables at time of the error" print
|
|
flush ;
|
|
|
|
: print-error ( error -- )
|
|
[
|
|
dup error.
|
|
restarts.
|
|
debug-help
|
|
] [
|
|
"Error in print-error!" print
|
|
] recover drop ;
|
|
|
|
: try ( quot -- ) [ print-error ] recover ;
|
|
|
|
: save-error ( error continuation -- )
|
|
error-continuation set-global
|
|
dup error set-global
|
|
compute-restarts restarts set-global ;
|
|
|
|
: error-handler ( error -- )
|
|
dup continuation save-error rethrow ;
|
|
|
|
: init-error-handler ( -- )
|
|
V{ } clone set-catchstack
|
|
( kernel calls on error )
|
|
[ error-handler ] 5 setenv
|
|
\ kernel-error 12 setenv ;
|