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 : 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> swap slip >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. "Data" stack-underflow. ;
 147 : datastack-overflow. "Data" stack-overflow. ;
 148 : retainstack-underflow. "Retain" stack-underflow. ;
 149 : retainstack-overflow. "Retain" stack-overflow. ;
 150
 151 : memory-error.
 152     "Memory protection fault at address " write third .h ;
 153
 154 : primitive-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
 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 no-method-generic pprint
 194     " does not define a method for the " write
 195     dup no-method-object class pprint
 196     " class." print
 197     "Allowed classes: " write dup no-method-generic order .
 198     "Dispatching on object: " write no-method-object short. ;
 199
 200 M: no-math-method summary
 201     drop "No suitable arithmetic method" ;
 202
 203 M: no-next-method summary
 204     drop "Executing call-next-method from least-specific method" ;
 205
 206 M: inconsistent-next-method summary
 207     drop "Executing call-next-method with inconsistent parameters" ;
 208
 209 M: check-method summary
 210     drop "Invalid parameters for create-method" ;
 211
 212 M: no-tuple-class summary
 213     drop "BOA constructors can only be defined for tuple classes" ;
 214
 215 M: bad-superclass summary
 216     drop "Tuple classes can only inherit from other tuple classes" ;
 217
 218 M: no-cond summary
 219     drop "Fall-through in cond" ;
 220
 221 M: no-case summary
 222     drop "Fall-through in case" ;
 223
 224 M: slice-error error.
 225     "Cannot create slice because " write
 226     slice-error-reason print ;
 227
 228 M: bounds-error summary drop "Sequence index out of bounds" ;
 229
 230 M: condition error. error>> error. ;
 231
 232 M: condition summary error>> summary ;
 233
 234 M: condition error-help error>> error-help ;
 235
 236 M: assert summary drop "Assertion failed" ;
 237
 238 M: assert error.
 239     "Assertion failed" print
 240     standard-table-style [
 241         15 length-limit set
 242         5 line-limit set
 243         [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
 244         [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
 245     ] tabular-output ;
 246
 247 M: immutable summary drop "Sequence is immutable" ;
 248
 249 M: redefine-error error.
 250     "Re-definition of " write
 251     redefine-error-def . ;
 252
 253 M: undefined summary
 254     drop "Calling a deferred word before it has been defined" ;
 255
 256 M: no-compilation-unit error.
 257     "Attempting to define " write
 258     no-compilation-unit-definition pprint
 259     " outside of a compilation unit" print ;
 260
 261 M: no-vocab summary
 262     drop "Vocabulary does not exist" ;
 263
 264 M: bad-ptr summary
 265     drop "Memory allocation failed" ;
 266
 267 M: double-free summary
 268     drop "Free failed since memory is not allocated" ;
 269
 270 M: realloc-error summary
 271     drop "Memory reallocation failed" ;
 272
 273 : error-in-thread. ( thread -- )
 274     "Error in thread " write
 275     [
 276         dup thread-id #
 277         " (" % dup thread-name %
 278         ", " % dup thread-quot unparse-short % ")" %
 279     ] "" make swap write-object ":" print nl ;
 280
 281 ! Hooks
 282 M: thread error-in-thread ( error thread -- )
 283     initial-thread get-global eq? [
 284         die drop
 285     ] [
 286         global [
 287             error-thread get-global error-in-thread. print-error flush
 288         ] bind
 289     ] if ;
 290
 291 M: encode-error summary drop "Character encoding error" ;
 292
 293 M: decode-error summary drop "Character decoding error" ;
 294
 295 M: no-such-slot summary drop "No such slot" ;
 296
 297 M: immutable-slot summary drop "Slot is immutable" ;
 298
 299 M: bad-create summary drop "Bad parameters to create" ;
 300
 301 <PRIVATE
 302
 303 : init-debugger ( -- )
 304     V{ } clone set-catchstack
 305     ! VM calls on error
 306     [
 307         self error-thread set-global
 308         continuation error-continuation set-global
 309         rethrow
 310     ] 5 setenv
 311     ! VM adds this to kernel errors, so that user-space
 312     ! can identify them
 313     "kernel-error" 6 setenv ;
 314
 315 PRIVATE>
 316
 317 [ init-debugger ] "debugger" add-init-hook