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