core/debugger/debugger.factor

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