core/debugger/debugger.factor

   1 ! Copyright (C) 2004, 2008 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 classes.tuple continuations continuations.private combinators
   7 generic.math io.streams.duplex classes.builtin classes
   8 compiler.units generic.standard vocabs threads threads.private
   9 init kernel.private libc io.encodings mirrors accessors ;
  10 IN: debugger
  11
  12 GENERIC: error. ( error -- )
  13 GENERIC: error-help ( error -- topic )
  14
  15 M: object error. . ;
  16 M: object error-help drop f ;
  17
  18 M: tuple error. describe ;
  19 M: tuple error-help class ;
  20
  21 M: string error. print ;
  22
  23 : :s ( -- )
  24     error-continuation get continuation-data stack. ;
  25
  26 : :r ( -- )
  27     error-continuation get continuation-retain stack. ;
  28
  29 : :c ( -- )
  30     error-continuation get continuation-call callstack. ;
  31
  32 : :get ( variable -- value )
  33     error-continuation get continuation-name assoc-stack ;
  34
  35 : :vars ( -- )
  36     error-continuation get continuation-name namestack. ;
  37
  38 : :res ( n -- )
  39     1- restarts get-global nth f restarts set-global restart ;
  40
  41 : :1 1 :res ;
  42 : :2 2 :res ;
  43 : :3 3 :res ;
  44
  45 : restart. ( restart n -- )
  46     [
  47         1+ dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
  48         restart-name %
  49     ] "" make print ;
  50
  51 : restarts. ( -- )
  52     restarts get dup empty? [
  53         drop
  54     ] [
  55         nl
  56         "The following restarts are available:" print
  57         nl
  58         dup length [ restart. ] 2each
  59     ] if ;
  60
  61 : print-error ( error -- )
  62     [ error. flush ] curry
  63     [ global [ "Error in print-error!" print drop ] bind ]
  64     recover ;
  65
  66 SYMBOL: error-hook
  67
  68 [
  69     print-error
  70     restarts.
  71     nl
  72     "Type :help for debugging help." print flush
  73 ] error-hook set-global
  74
  75 : try ( quot -- )
  76     [ error-hook get call ] recover ;
  77
  78 ERROR: assert got expect ;
  79
  80 : assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;
  81
  82 : depth ( -- n ) datastack length ;
  83
  84 : trim-datastacks ( seq1 seq2 -- seq1' seq2' )
  85     2dup [ length ] bi@ min tuck tail >r tail r> ;
  86
  87 ERROR: relative-underflow stack ;
  88
  89 M: relative-underflow summary
  90     drop "Too many items removed from data stack" ;
  91
  92 ERROR: relative-overflow stack ;
  93
  94 M: relative-overflow summary
  95     drop "Superfluous items pushed to data stack" ;
  96
  97 : assert-depth ( quot -- )
  98     >r datastack r> swap slip >r datastack r>
  99     2dup [ length ] compare sgn {
 100         { -1 [ trim-datastacks nip relative-underflow ] }
 101         { 0 [ 2drop ] }
 102         { 1 [ trim-datastacks drop relative-overflow ] }
 103     } case ; inline
 104
 105 : expired-error. ( obj -- )
 106     "Object did not survive image save/load: " write third . ;
 107
 108 : io-error. ( error -- )
 109     "I/O error: " write third print ;
 110
 111 : type-check-error. ( obj -- )
 112     "Type check error" print
 113     "Object: " write dup fourth short.
 114     "Object type: " write dup fourth class .
 115     "Expected type: " write third type>class . ;
 116
 117 : divide-by-zero-error. ( obj -- )
 118     "Division by zero" print drop ;
 119
 120 : signal-error. ( obj -- )
 121     "Operating system signal " write third . ;
 122
 123 : array-size-error. ( obj -- )
 124     "Invalid array size: " write dup third .
 125     "Maximum: " write fourth 1- . ;
 126
 127 : c-string-error. ( obj -- )
 128     "Cannot convert to C string: " write third . ;
 129
 130 : ffi-error. ( obj -- )
 131     "FFI: " write
 132     dup third [ write ": " write ] when*
 133     fourth print ;
 134
 135 : heap-scan-error. ( obj -- )
 136     "Cannot do next-object outside begin/end-scan" print drop ;
 137
 138 : undefined-symbol-error. ( obj -- )
 139     "The image refers to a library or symbol that was not found"
 140     " at load time" append print drop ;
 141
 142 : stack-underflow. ( obj name -- )
 143     write " stack underflow" print drop ;
 144
 145 : stack-overflow. ( obj name -- )
 146     write " stack overflow" print drop ;
 147
 148 : datastack-underflow. "Data" stack-underflow. ;
 149 : datastack-overflow. "Data" stack-overflow. ;
 150 : retainstack-underflow. "Retain" stack-underflow. ;
 151 : retainstack-overflow. "Retain" stack-overflow. ;
 152
 153 : memory-error.
 154     "Memory protection fault at address " write third .h ;
 155
 156 : primitive-error.
 157     "Unimplemented primitive" print drop ;
 158
 159 PREDICATE: kernel-error < array
 160     {
 161         { [ dup empty? ] [ drop f ] }
 162         { [ dup first "kernel-error" = not ] [ drop f ] }
 163         [ second 0 15 between? ]
 164     } cond ;
 165
 166 : kernel-errors
 167     second {
 168         { 0  [ expired-error.          ] }
 169         { 1  [ io-error.               ] }
 170         { 2  [ primitive-error.        ] }
 171         { 3  [ type-check-error.       ] }
 172         { 4  [ divide-by-zero-error.   ] }
 173         { 5  [ signal-error.           ] }
 174         { 6  [ array-size-error.       ] }
 175         { 7  [ c-string-error.         ] }
 176         { 8  [ ffi-error.              ] }
 177         { 9  [ heap-scan-error.        ] }
 178         { 10 [ undefined-symbol-error. ] }
 179         { 11 [ datastack-underflow.    ] }
 180         { 12 [ datastack-overflow.     ] }
 181         { 13 [ retainstack-underflow.  ] }
 182         { 14 [ retainstack-overflow.   ] }
 183         { 15 [ memory-error.           ] }
 184     } ; inline
 185
 186 M: kernel-error error. dup kernel-errors case ;
 187
 188 M: kernel-error error-help kernel-errors at first ;
 189
 190 M: no-method summary
 191     drop "No suitable method" ;
 192
 193 M: no-method error.
 194     "Generic word " write
 195     dup no-method-generic pprint
 196     " does not define a method for the " write
 197     dup no-method-object class pprint
 198     " class." print
 199     "Allowed classes: " write dup no-method-generic order .
 200     "Dispatching on object: " write no-method-object short. ;
 201
 202 M: no-math-method summary
 203     drop "No suitable arithmetic method" ;
 204
 205 M: no-next-method summary
 206     drop "Executing call-next-method from least-specific method" ;
 207
 208 M: inconsistent-next-method summary
 209     drop "Executing call-next-method with inconsistent parameters" ;
 210
 211 M: stream-closed-twice summary
 212     drop "Attempt to perform I/O on closed stream" ;
 213
 214 M: check-method summary
 215     drop "Invalid parameters for create-method" ;
 216
 217 M: no-tuple-class summary
 218     drop "BOA constructors can only be defined for tuple classes" ;
 219
 220 M: bad-superclass summary
 221     drop "Tuple classes can only inherit from other tuple classes" ;
 222
 223 M: no-cond summary
 224     drop "Fall-through in cond" ;
 225
 226 M: no-case summary
 227     drop "Fall-through in case" ;
 228
 229 M: slice-error error.
 230     "Cannot create slice because " write
 231     slice-error-reason print ;
 232
 233 M: bounds-error summary drop "Sequence index out of bounds" ;
 234
 235 M: condition error. error>> error. ;
 236
 237 M: condition summary error>> summary ;
 238
 239 M: condition error-help error>> error-help ;
 240
 241 M: assert summary drop "Assertion failed" ;
 242
 243 M: immutable summary drop "Sequence is immutable" ;
 244
 245 M: redefine-error error.
 246     "Re-definition of " write
 247     redefine-error-def . ;
 248
 249 M: undefined summary
 250     drop "Calling a deferred word before it has been defined" ;
 251
 252 M: no-compilation-unit error.
 253     "Attempting to define " write
 254     no-compilation-unit-definition pprint
 255     " outside of a compilation unit" print ;
 256
 257 M: no-vocab summary
 258     drop "Vocabulary does not exist" ;
 259
 260 M: bad-ptr summary
 261     drop "Memory allocation failed" ;
 262
 263 M: double-free summary
 264     drop "Free failed since memory is not allocated" ;
 265
 266 M: realloc-error summary
 267     drop "Memory reallocation failed" ;
 268
 269 : error-in-thread. ( -- )
 270     error-thread get-global
 271     "Error in thread " write
 272     [
 273         dup thread-id #
 274         " (" % dup thread-name %
 275         ", " % dup thread-quot unparse-short % ")" %
 276     ] "" make swap write-object ":" print nl ;
 277
 278 ! Hooks
 279 M: thread error-in-thread ( error thread -- )
 280     initial-thread get-global eq? [
 281         die drop
 282     ] [
 283         global [
 284             error-in-thread. print-error flush
 285         ] bind
 286     ] if ;
 287
 288 M: encode-error summary drop "Character encoding error" ;
 289
 290 M: decode-error summary drop "Character decoding error" ;
 291
 292 M: no-such-slot summary drop "No such slot" ;
 293
 294 M: immutable-slot summary drop "Slot is immutable" ;
 295
 296 M: bad-create summary drop "Bad parameters to create" ;
 297
 298 <PRIVATE
 299
 300 : init-debugger ( -- )
 301     V{ } clone set-catchstack
 302     ! VM calls on error
 303     [
 304         self error-thread set-global
 305         continuation error-continuation set-global
 306         rethrow
 307     ] 5 setenv
 308     ! VM adds this to kernel errors, so that user-space
 309     ! can identify them
 310     "kernel-error" 6 setenv ;
 311
 312 PRIVATE>
 313
 314 [ init-debugger ] "debugger" add-init-hook