basis/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 io.files vectors
   6 words system 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 accessors
  10 math.order destructors source-files parser classes.tuple.parser
  11 effects.parser lexer compiler.errors dlists generic.parser
  12 strings.parser ;
  13 IN: debugger
  14
  15 GENERIC: error. ( error -- )
  16 GENERIC: error-help ( error -- topic )
  17
  18 M: object error. . ;
  19 M: object error-help drop f ;
  20
  21 M: tuple error-help class ;
  22
  23 M: string error. print ;
  24
  25 : :s ( -- )
  26     error-continuation get continuation-data stack. ;
  27
  28 : :r ( -- )
  29     error-continuation get continuation-retain stack. ;
  30
  31 : :c ( -- )
  32     error-continuation get continuation-call callstack. ;
  33
  34 : :get ( variable -- value )
  35     error-continuation get continuation-name assoc-stack ;
  36
  37 : :res ( n -- * )
  38     1- restarts get-global nth f restarts set-global restart ;
  39
  40 : :1 ( -- * ) 1 :res ;
  41 : :2 ( -- * ) 2 :res ;
  42 : :3 ( -- * ) 3 :res ;
  43
  44 : restart. ( restart n -- )
  45     [
  46         1+ dup 3 <= [ ":" % # "    " % ] [ # " :res  " % ] if
  47         restart-name %
  48     ] "" make print ;
  49
  50 : restarts. ( -- )
  51     restarts get dup empty? [
  52         drop
  53     ] [
  54         nl
  55         "The following restarts are available:" print
  56         nl
  57         [ restart. ] each-index
  58     ] if ;
  59
  60 : print-error ( error -- )
  61     [ error. flush ] curry
  62     [ global [ "Error in print-error!" print drop ] bind ]
  63     recover ;
  64
  65 : print-error-and-restarts ( error -- )
  66     print-error
  67     restarts.
  68     nl
  69     "Type :help for debugging help." print flush ;
  70
  71 : try ( quot -- )
  72     [ print-error-and-restarts ] recover ;
  73
  74 M: relative-underflow summary
  75     drop "Too many items removed from data stack" ;
  76
  77 M: relative-overflow summary
  78     drop "Superfluous items pushed to data stack" ;
  79
  80 : expired-error. ( obj -- )
  81     "Object did not survive image save/load: " write third . ;
  82
  83 : io-error. ( error -- )
  84     "I/O error: " write third print ;
  85
  86 : type-check-error. ( obj -- )
  87     "Type check error" print
  88     "Object: " write dup fourth short.
  89     "Object type: " write dup fourth class .
  90     "Expected type: " write third type>class . ;
  91
  92 : divide-by-zero-error. ( obj -- )
  93     "Division by zero" print drop ;
  94
  95 : signal-error. ( obj -- )
  96     "Operating system signal " write third . ;
  97
  98 : array-size-error. ( obj -- )
  99     "Invalid array size: " write dup third .
 100     "Maximum: " write fourth 1- . ;
 101
 102 : c-string-error. ( obj -- )
 103     "Cannot convert to C string: " write third . ;
 104
 105 : ffi-error. ( obj -- )
 106     "FFI: " write
 107     dup third [ write ": " write ] when*
 108     fourth print ;
 109
 110 : heap-scan-error. ( obj -- )
 111     "Cannot do next-object outside begin/end-scan" print drop ;
 112
 113 : undefined-symbol-error. ( obj -- )
 114     "The image refers to a library or symbol that was not found"
 115     " at load time" append print drop ;
 116
 117 : stack-underflow. ( obj name -- )
 118     write " stack underflow" print drop ;
 119
 120 : stack-overflow. ( obj name -- )
 121     write " stack overflow" print drop ;
 122
 123 : datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
 124 : datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
 125 : retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
 126 : retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
 127
 128 : memory-error. ( error -- )
 129     "Memory protection fault at address " write third .h ;
 130
 131 : primitive-error. ( error -- )
 132     "Unimplemented primitive" print drop ;
 133
 134 PREDICATE: kernel-error < array
 135     {
 136         { [ dup empty? ] [ drop f ] }
 137         { [ dup first "kernel-error" = not ] [ drop f ] }
 138         [ second 0 15 between? ]
 139     } cond ;
 140
 141 : kernel-errors ( error -- n errors )
 142     second {
 143         { 0  [ expired-error.          ] }
 144         { 1  [ io-error.               ] }
 145         { 2  [ primitive-error.        ] }
 146         { 3  [ type-check-error.       ] }
 147         { 4  [ divide-by-zero-error.   ] }
 148         { 5  [ signal-error.           ] }
 149         { 6  [ array-size-error.       ] }
 150         { 7  [ c-string-error.         ] }
 151         { 8  [ ffi-error.              ] }
 152         { 9  [ heap-scan-error.        ] }
 153         { 10 [ undefined-symbol-error. ] }
 154         { 11 [ datastack-underflow.    ] }
 155         { 12 [ datastack-overflow.     ] }
 156         { 13 [ retainstack-underflow.  ] }
 157         { 14 [ retainstack-overflow.   ] }
 158         { 15 [ memory-error.           ] }
 159     } ; inline
 160
 161 M: kernel-error error. dup kernel-errors case ;
 162
 163 M: kernel-error error-help kernel-errors at first ;
 164
 165 M: no-method summary
 166     drop "No suitable method" ;
 167
 168 M: no-method error.
 169     "Generic word " write
 170     dup generic>> pprint
 171     " does not define a method for the " write
 172     dup object>> class pprint
 173     " class." print
 174     "Dispatching on object: " write object>> short. ;
 175
 176 M: bad-slot-value summary drop "Bad store to specialized slot" ;
 177
 178 M: no-math-method summary
 179     drop "No suitable arithmetic method" ;
 180
 181 M: no-next-method summary
 182     drop "Executing call-next-method from least-specific method" ;
 183
 184 M: inconsistent-next-method summary
 185     drop "Executing call-next-method with inconsistent parameters" ;
 186
 187 M: check-method summary
 188     drop "Invalid parameters for create-method" ;
 189
 190 M: not-a-tuple summary
 191     drop "Not a tuple" ;
 192
 193 M: bad-superclass summary
 194     drop "Tuple classes can only inherit from other tuple classes" ;
 195
 196 M: no-initial-value summary
 197     drop "Initial value must be provided for slots specialized to this class" ;
 198
 199 M: bad-initial-value summary
 200     drop "Incompatible initial value" ;
 201
 202 M: no-cond summary
 203     drop "Fall-through in cond" ;
 204
 205 M: no-case summary
 206     drop "Fall-through in case" ;
 207
 208 M: slice-error error.
 209     "Cannot create slice because " write
 210     slice-error-reason print ;
 211
 212 M: bounds-error summary drop "Sequence index out of bounds" ;
 213
 214 M: condition error. error>> error. ;
 215
 216 M: condition summary error>> summary ;
 217
 218 M: condition error-help error>> error-help ;
 219
 220 M: assert summary drop "Assertion failed" ;
 221
 222 M: assert error.
 223     "Assertion failed" print
 224     standard-table-style [
 225         15 length-limit set
 226         5 line-limit set
 227         [ expect>> [ [ "Expect:" write ] with-cell pprint-cell ] with-row ]
 228         [ got>> [ [ "Got:" write ] with-cell pprint-cell ] with-row ] bi
 229     ] tabular-output ;
 230
 231 M: immutable summary drop "Sequence is immutable" ;
 232
 233 M: redefine-error error.
 234     "Re-definition of " write
 235     redefine-error-def . ;
 236
 237 M: undefined summary
 238     drop "Calling a deferred word before it has been defined" ;
 239
 240 M: no-compilation-unit error.
 241     "Attempting to define " write
 242     no-compilation-unit-definition pprint
 243     " outside of a compilation unit" print ;
 244
 245 M: no-vocab summary
 246     drop "Vocabulary does not exist" ;
 247
 248 M: bad-ptr summary
 249     drop "Memory allocation failed" ;
 250
 251 M: double-free summary
 252     drop "Free failed since memory is not allocated" ;
 253
 254 M: realloc-error summary
 255     drop "Memory reallocation failed" ;
 256
 257 : error-in-thread. ( thread -- )
 258     "Error in thread " write
 259     [
 260         dup thread-id #
 261         " (" % dup thread-name %
 262         ", " % dup thread-quot unparse-short % ")" %
 263     ] "" make swap write-object ":" print nl ;
 264
 265 ! Hooks
 266 M: thread error-in-thread ( error thread -- )
 267     initial-thread get-global eq? [
 268         die drop
 269     ] [
 270         global [
 271             error-thread get-global error-in-thread. print-error flush
 272         ] bind
 273     ] if ;
 274
 275 M: encode-error summary drop "Character encoding error" ;
 276
 277 M: decode-error summary drop "Character decoding error" ;
 278
 279 M: bad-create summary drop "Bad parameters to create" ;
 280
 281 M: attempt-all-error summary drop "Nothing to attempt" ;
 282
 283 M: already-disposed summary drop "Attempting to operate on disposed object" ;
 284
 285 M: no-current-vocab summary
 286     drop "Not in a vocabulary; IN: form required" ;
 287
 288 M: no-word-error summary
 289     drop "Word not found in current vocabulary search path" ;
 290
 291 M: staging-violation summary
 292     drop
 293     "A parsing word cannot be used in the same file it is defined in." ;
 294
 295 M: bad-number summary
 296     drop "Bad number literal" ;
 297
 298 M: duplicate-slot-names summary
 299     drop "Duplicate slot names" ;
 300
 301 M: invalid-slot-name summary
 302     drop "Invalid slot name" ;
 303
 304 : file. ( file -- ) path>> <pathname> . ;
 305
 306 M: source-file-error error.
 307     [ file>> file. ] [ error>> error. ] bi ;
 308
 309 M: source-file-error summary
 310     error>> summary ;
 311
 312 M: source-file-error compute-restarts
 313     error>> compute-restarts ;
 314
 315 M: source-file-error error-help
 316     error>> error-help ;
 317
 318 M: not-in-a-method-error summary
 319     drop "call-next-method can only be called in a method definition" ;
 320
 321 GENERIC: expected>string ( obj -- str )
 322
 323 M: f expected>string drop "end of input" ;
 324 M: word expected>string name>> ;
 325 M: string expected>string ;
 326
 327 M: unexpected error.
 328     "Expected " write
 329     dup unexpected-want expected>string write
 330     " but got " write
 331     unexpected-got expected>string print ;
 332
 333 M: lexer-error error.
 334     [ lexer-dump ] [ error>> error. ] bi ;
 335
 336 M: lexer-error summary
 337     error>> summary ;
 338
 339 M: lexer-error compute-restarts
 340     error>> compute-restarts ;
 341
 342 M: lexer-error error-help
 343     error>> error-help ;
 344
 345 M: object compiler-error. ( error word -- )
 346     nl
 347     "While compiling " write pprint ": " print
 348     nl
 349     print-error ;
 350
 351 M: empty-dlist summary ( dlist -- )
 352     drop "Empty dlist" ;
 353
 354 M: bad-effect summary
 355     drop "Bad stack effect declaration" ;
 356
 357 M: bad-escape summary drop "Bad escape code" ;