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