core/debugger/debugger.factor

   1 ! Copyright (C) 2004, 2007 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: arrays definitions generic hashtables inspector io kernel
   4 math namespaces prettyprint sequences assocs sequences.private
   5 strings io.styles vectors words system splitting math.parser
   6 tuples continuations continuations.private combinators
   7 generic.math io.streams.duplex classes
   8 generic.standard ;
   9 IN: debugger
  10
  11 GENERIC: error. ( error -- )
  12 GENERIC: error-help ( error -- topic )
  13
  14 M: object error. . ;
  15 M: object error-help drop f ;
  16
  17 M: tuple error. describe ;
  18 M: tuple error-help class ;
  19
  20 M: string error. print ;
  21
  22 : :s ( -- )
  23     error-continuation get continuation-data stack. ;
  24
  25 : :r ( -- )
  26     error-continuation get continuation-retain stack. ;
  27
  28 : :c ( -- )
  29     error-continuation get continuation-call callstack. ;
  30
  31 : :get ( variable -- value )
  32     error-continuation get continuation-name assoc-stack ;
  33
  34 : :res ( n -- )
  35     1- restarts get-global nth f restarts set-global restart ;
  36
  37 : :1 1 :res ;
  38 : :2 2 :res ;
  39 : :3 3 :res ;
  40
  41 : restart. ( restart n -- )
  42     [
  43         1+ dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
  44         restart-name %
  45     ] "" make print ;
  46
  47 : restarts. ( -- )
  48     restarts get dup empty? [
  49         drop
  50     ] [
  51         nl
  52         "The following restarts are available:" print
  53         nl
  54         dup length [ restart. ] 2each
  55     ] if ;
  56
  57 : debug-help ( -- )
  58     nl
  59     "Debugger commands:" print
  60     nl
  61     ":help - documentation for this error" print
  62     ":s    - data stack at exception time" print
  63     ":r    - retain stack at exception time" print
  64     ":c    - call stack at exception time" print
  65     ":edit - jump to source location (parse errors only)" print
  66
  67     ":get  ( var -- value ) accesses variables at time of the error" print
  68     flush ;
  69
  70 : print-error ( error -- )
  71     [ error. flush ] curry
  72     [ global [ "Error in print-error!" print drop ] bind ]
  73     recover ;
  74
  75 SYMBOL: error-hook
  76
  77 [ print-error restarts. debug-help ] error-hook set-global
  78
  79 : try ( quot -- )
  80     [ error-hook get call ] recover ;
  81
  82 TUPLE: assert got expect ;
  83
  84 : assert ( got expect -- * ) \ assert construct-boa throw ;
  85
  86 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
  87
  88 : depth ( -- n ) datastack length ;
  89
  90 : assert-depth ( quot -- ) depth slip depth swap assert= ;
  91
  92 : expired-error. ( obj -- )
  93     "Object did not survive image save/load: " write third . ;
  94
  95 : undefined-word-error. ( obj -- )
  96     "Undefined word: " write third . ;
  97
  98 : io-error. ( error -- )
  99     "I/O error: " write third print ;
 100
 101 : type-check-error. ( obj -- )
 102     "Type check error" print
 103     "Object: " write dup fourth short.
 104     "Object type: " write dup fourth class .
 105     "Expected type: " write third type>class . ;
 106
 107 : divide-by-zero-error. ( obj -- )
 108     "Division by zero" print drop ;
 109
 110 : signal-error. ( obj -- )
 111     "Operating system signal " write third . ;
 112
 113 : array-size-error. ( obj -- )
 114     "Invalid array size: " write dup third .
 115     "Maximum: " write fourth 1- . ;
 116
 117 : c-string-error. ( obj -- )
 118     "Cannot convert to C string: " write third . ;
 119
 120 : ffi-error. ( obj -- )
 121     "FFI: " write
 122     dup third [ write ": " write ] when*
 123     fourth print ;
 124
 125 : heap-scan-error. ( obj -- )
 126     "Cannot do next-object outside begin/end-scan" print drop ;
 127
 128 : undefined-symbol-error. ( obj -- )
 129     "The image refers to a library or symbol that was not found"
 130     " at load time" append print drop ;
 131
 132 : stack-underflow. ( obj name -- )
 133     write " stack underflow" print drop ;
 134
 135 : stack-overflow. ( obj name -- )
 136     write " stack overflow" print drop ;
 137
 138 : datastack-underflow. "Data" stack-underflow. ;
 139 : datastack-overflow. "Data" stack-overflow. ;
 140 : retainstack-underflow. "Retain" stack-underflow. ;
 141 : retainstack-overflow. "Retain" stack-overflow. ;
 142
 143 : memory-error.
 144     "Memory protection fault at address " write third .h ;
 145
 146 : primitive-error.
 147     "Unimplemented primitive" print drop ;
 148
 149 PREDICATE: array kernel-error ( obj -- ? )
 150     {
 151         { [ dup empty? ] [ drop f ] }
 152         { [ dup first "kernel-error" = not ] [ drop f ] }
 153         { [ t ] [ second 0 16 between? ] }
 154     } cond ;
 155
 156 : kernel-errors
 157     second {
 158         { 0  [ expired-error.          ] }
 159         { 1  [ io-error.               ] }
 160         { 2  [ undefined-word-error.   ] }
 161         { 3  [ type-check-error.       ] }
 162         { 4  [ divide-by-zero-error.   ] }
 163         { 5  [ signal-error.           ] }
 164         { 6  [ array-size-error.       ] }
 165         { 7  [ c-string-error.         ] }
 166         { 8  [ ffi-error.              ] }
 167         { 9  [ heap-scan-error.        ] }
 168         { 10 [ undefined-symbol-error. ] }
 169         { 11 [ datastack-underflow.    ] }
 170         { 12 [ datastack-overflow.     ] }
 171         { 13 [ retainstack-underflow.  ] }
 172         { 14 [ retainstack-overflow.   ] }
 173         { 15 [ memory-error.           ] }
 174         { 16 [ primitive-error.        ] }
 175     } ; inline
 176
 177 M: kernel-error error. dup kernel-errors case ;
 178
 179 M: kernel-error error-help kernel-errors at first ;
 180
 181 M: no-method summary
 182     drop "No suitable method" ;
 183
 184 M: no-method error.
 185     "Generic word " write
 186     dup no-method-generic pprint
 187     " does not define a method for the " write
 188     dup no-method-object class pprint
 189     " class." print
 190     "Allowed classes: " write dup no-method-generic order .
 191     "Dispatching on object: " write no-method-object short. ;
 192
 193 M: no-math-method summary
 194     drop "No suitable arithmetic method" ;
 195
 196 M: check-closed summary
 197     drop "Attempt to perform I/O on closed stream" ;
 198
 199 M: check-method summary
 200     drop "Invalid parameters for define-method" ;
 201
 202 M: check-tuple summary
 203     drop "Invalid class for define-constructor" ;
 204
 205 M: no-cond summary
 206     drop "Fall-through in cond" ;
 207
 208 M: no-case summary
 209     drop "Fall-through in case" ;
 210
 211 M: slice-error error.
 212     "Cannot create slice because " write
 213     slice-error-reason print ;
 214
 215 M: bounds-error summary drop "Sequence index out of bounds" ;
 216
 217 M: condition error. delegate error. ;
 218
 219 M: condition error-help drop f ;
 220
 221 M: assert summary drop "Assertion failed" ;
 222
 223 M: immutable summary drop "Sequence is immutable" ;