core/debugger.factor

   1 ! Copyright (C) 2004, 2006 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions generic hashtables tools io
   4 kernel math namespaces parser prettyprint sequences
   5 sequences-internals strings styles vectors words errors ;
   6 IN: kernel-internals
   7
   8 : save-error ( error trace continuation -- )
   9     error-continuation set-global
  10     error-stack-trace set-global
  11     dup error set-global
  12     compute-restarts restarts set-global ;
  13
  14 : error-handler ( error trace -- )
  15     dupd continuation save-error rethrow ;
  16
  17 : init-error-handler ( -- )
  18     V{ } clone set-catchstack
  19     ! kernel calls on error
  20     [ error-handler ] 5 setenv
  21     \ kernel-error 12 setenv ;
  22
  23 : find-xt ( xt xtmap -- word )
  24     [ second - ] binsearch* first ;
  25
  26 : symbolic-stack-trace ( seq -- seq )
  27     xt-map 2 group swap [ dup rot find-xt 2array ] map-with ;
  28
  29 IN: errors
  30
  31 GENERIC: error. ( error -- )
  32 GENERIC: error-help ( error -- topic )
  33
  34 M: object error. . ;
  35 M: object error-help drop f ;
  36
  37 M: tuple error. describe ;
  38 M: tuple error-help class ;
  39
  40 M: string error. print ;
  41
  42 : :s ( -- )
  43     error-continuation get continuation-data stack. ;
  44
  45 : :r ( -- )
  46     error-continuation get continuation-retain stack. ;
  47
  48 : xt. ( xt -- )
  49     >hex cell 2 * CHAR: 0 pad-left write ;
  50
  51 : word-xt. ( xt word -- )
  52     "Compiled: " write dup pprint bl
  53     "(offset " write word-xt - >hex write ")" print ;
  54
  55 : :trace
  56     error-stack-trace get symbolic-stack-trace <reversed>
  57     [ first2 word-xt. ] each ;
  58
  59 : :c ( -- )
  60     error-continuation get continuation-call callstack. :trace ;
  61
  62 : :get ( variable -- value )
  63     error-continuation get continuation-name hash-stack ;
  64
  65 : :res ( n -- )
  66     restarts get-global nth f restarts set-global restart ;
  67
  68 : restart. ( restart n -- )
  69     [ # " :res  " % restart-name % ] "" make print ;
  70
  71 : restarts. ( -- )
  72     restarts get dup empty? [
  73         drop
  74     ] [
  75         terpri
  76         "The following restarts are available:" print
  77         terpri
  78         dup length [ restart. ] 2each
  79     ] if ;
  80
  81 : debug-help ( -- )
  82     terpri
  83     "Debugger commands:" print
  84     terpri
  85     ":help - documentation for this error" print
  86     ":s    - data stack at exception time" print
  87     ":r    - retain stack at exception time" print
  88     ":c    - call stack at exception time" print
  89
  90     error get [ parse-error? ] is? [
  91         ":edit - jump to source location" print
  92     ] when
  93
  94     ":get  ( var -- value ) accesses variables at time of the error" print
  95     flush ;
  96
  97 : print-error ( error -- )
  98     [
  99         dup error.
 100     ] [
 101         "Error in print-error!" print drop
 102     ] recover drop ;
 103
 104 SYMBOL: error-hook
 105
 106 [ print-error restarts. debug-help ] error-hook set-global
 107
 108 : try ( quot -- )
 109     [ error-hook get call ] recover ;