basis/debugger/debugger.factor

   1 ! Copyright (C) 2004, 2011 Slava Pestov.
   2 ! See http://factorcode.org/license.txt for BSD license.
   3 USING: accessors alien alien.strings arrays assocs classes
   4 classes.builtin classes.tuple classes.tuple.parser combinators
   5 combinators.short-circuit compiler.errors compiler.units
   6 continuations definitions destructors effects.parser fixups
   7 generic generic.math generic.parser generic.single grouping io
   8 io.encodings io.styles kernel kernel.private lexer libc make
   9 math math.order math.parser math.ratios namespaces parser
  10 prettyprint sequences sequences.private slots
  11 source-files.errors strings strings.parser summary system vocabs
  12 vocabs.loader vocabs.parser words ;
  13 IN: debugger
  14
  15 GENERIC: error-help ( error -- topic )
  16
  17 M: object error-help drop f ;
  18
  19 M: tuple error-help class-of ;
  20
  21 M: source-file-error error-help error>> error-help ;
  22
  23 GENERIC: error. ( error -- )
  24
  25 M: object error. short. ;
  26
  27 M: string error. print ;
  28
  29 : traceback-link. ( continuation -- )
  30     "[" write [ "Traceback" ] dip write-object "]" print ;
  31
  32 : :s ( -- )
  33     error-continuation get data>> stack. ;
  34
  35 : :r ( -- )
  36     error-continuation get retain>> stack. ;
  37
  38 : :c ( -- )
  39     error-continuation get call>> callstack. ;
  40
  41 : :get ( variable -- value )
  42     error-continuation get name>> assoc-stack ;
  43
  44 : :res ( n -- * )
  45     1 - restarts [ nth f ] change-global
  46     [ dup no-op-restart = [ drop f ] when ] change-obj
  47     continue-restart ;
  48
  49 : :1 ( -- * ) 1 :res ;
  50 : :2 ( -- * ) 2 :res ;
  51 : :3 ( -- * ) 3 :res ;
  52
  53 : restart. ( restart n -- )
  54     [
  55         1 + dup 3 <= [ ":" % # "      " % ] [ # " :res  " % ] if
  56         name>> %
  57     ] "" make print ;
  58
  59 : restarts. ( -- )
  60     restarts get [
  61         nl
  62         "The following restarts are available:" print
  63         nl
  64         [ restart. ] each-index
  65     ] unless-empty ;
  66
  67 : print-error ( error -- )
  68     [ error. flush ] curry
  69     [ [ "Error in print-error!" print drop ] with-global ]
  70     recover ;
  71
  72 : :error ( -- )
  73     error get print-error ;
  74
  75 : print-error-and-restarts ( error -- )
  76     print-error
  77     restarts.
  78     nl
  79     "Type :help for debugging help." print flush ;
  80
  81 : try ( quot -- )
  82     [ print-error-and-restarts ] recover ; inline
  83
  84 : expired-error. ( obj -- )
  85     "Object did not survive image save/load: " write third . ;
  86
  87 : io-error. ( error -- )
  88     "I/O error #" write third [ . ] [ strerror print ] bi ;
  89
  90 : type-check-error. ( obj -- )
  91     "Type check error" print
  92     "Object: " write dup fourth short.
  93     "Object type: " write dup fourth class-of .
  94     "Expected type: " write third type>class . ;
  95
  96 : divide-by-zero-error. ( obj -- )
  97     "Division by zero" print drop ;
  98
  99 HOOK: signal-error. os ( obj -- )
 100
 101 : array-size-error. ( obj -- )
 102     "Invalid array size: " write dup third .
 103     "Maximum: " write fourth 1 - . ;
 104
 105 : fixnum-range-error. ( obj -- )
 106     "Cannot convert to fixnum: " write third . ;
 107
 108 : ffi-error. ( obj -- )
 109     "FFI error" print drop ;
 110
 111 : find-ffi-error ( string -- error )
 112     [ linkage-errors get ] dip
 113     '[ nip asset>> name>> _ = ] assoc-find drop nip
 114     [ error>> message>> ] [ "none" ] if* ;
 115
 116 : undefined-symbol-error. ( obj -- )
 117     "Cannot resolve C library function" print
 118     "Library: " write dup fourth .
 119     third symbol>string
 120     [ "Symbol: " write print ]
 121     [ "DlError: " write find-ffi-error print ] bi
 122     "See http://concatenative.org/wiki/view/Factor/Requirements" print ;
 123
 124 : stack-underflow. ( obj name -- )
 125     write " stack underflow" print drop ;
 126
 127 : stack-overflow. ( obj name -- )
 128     write " stack overflow" print drop ;
 129
 130 : datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
 131 : datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
 132 : retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
 133 : retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
 134 : callstack-underflow. ( obj -- ) "Call" stack-underflow. ;
 135 : callstack-overflow. ( obj -- ) "Call" stack-overflow. ;
 136
 137 : memory-error. ( error -- )
 138     "Memory protection fault at address " write third .h ;
 139
 140 : fp-trap-error. ( error -- )
 141     "Floating point trap" print drop ;
 142
 143 : interrupt-error. ( error -- )
 144     "Interrupt" print drop ;
 145
 146 : callback-space-overflow. ( error -- )
 147     "Callback space overflow" print drop ;
 148
 149 PREDICATE: vm-error < array
 150     dup length 2 < [ drop f ] [
 151         {
 152             [ first-unsafe KERNEL-ERROR = ]
 153             [ second-unsafe 0 kernel-error-count 1 - between? ]
 154         } 1&&
 155     ] if ;
 156
 157 : vm-errors ( error -- n errors )
 158     second {
 159         [ expired-error.           ]
 160         [ io-error.                ]
 161         [ drop                     ]
 162         [ type-check-error.        ]
 163         [ divide-by-zero-error.    ]
 164         [ signal-error.            ]
 165         [ array-size-error.        ]
 166         [ fixnum-range-error.      ]
 167         [ ffi-error.               ]
 168         [ undefined-symbol-error.  ]
 169         [ datastack-underflow.     ]
 170         [ datastack-overflow.      ]
 171         [ retainstack-underflow.   ]
 172         [ retainstack-overflow.    ]
 173         [ callstack-underflow.     ]
 174         [ callstack-overflow.      ]
 175         [ memory-error.            ]
 176         [ fp-trap-error.           ]
 177         [ interrupt-error.         ]
 178         [ callback-space-overflow. ]
 179     } ; inline
 180
 181 M: vm-error summary drop "VM error" ;
 182
 183 M: vm-error error. dup vm-errors dispatch ;
 184
 185 M: vm-error error-help vm-errors nth first ;
 186
 187 M: division-by-zero summary
 188     drop "Division by zero" ;
 189
 190 M: no-method summary
 191     drop "No suitable method" ;
 192
 193 M: no-method error.
 194     "Generic word " write
 195     dup generic>> pprint
 196     " does not define a method for the " write
 197     dup object>> class-of pprint
 198     " class." print
 199     "Dispatching on object: " write object>> short. ;
 200
 201 M: bad-slot-value summary drop "Bad store to specialized slot" ;
 202
 203 M: bad-slot-name summary drop "Bad slot name in object literal" ;
 204
 205 M: bad-vocab-name summary drop "Vocab name cannot contain \":/\\ \"" ;
 206
 207 M: no-math-method summary
 208     drop "No suitable arithmetic method" ;
 209
 210 M: no-next-method summary
 211     drop "Executing call-next-method from least-specific method" ;
 212
 213 M: inconsistent-next-method summary
 214     drop "Executing call-next-method with inconsistent parameters" ;
 215
 216 M: check-method-error summary
 217     drop "Invalid parameters for create-method" ;
 218
 219 M: bad-superclass summary
 220     drop "Tuple classes can only inherit from non-final tuple classes" ;
 221
 222 M: bad-initial-value summary
 223     drop "Incompatible initial value" ;
 224
 225 M: no-cond summary
 226     drop "Fall-through in cond" ;
 227
 228 M: no-case summary
 229     drop "Fall-through in case" ;
 230
 231 M: slice-error summary
 232     "Cannot create slice" swap {
 233         { [ dup from>> 0 < ] [ ": from < 0" ] }
 234         { [ dup [ to>> ] [ seq>> length ] bi > ] [ ": to > length" ] }
 235         { [ dup [ from>> ] [ to>> ] bi > ] [ ": from > to" ] }
 236         [ f ]
 237     } cond nip append ;
 238
 239 M: bounds-error summary drop "Sequence index out of bounds" ;
 240
 241 M: groups-error summary drop "Non positive group size" ;
 242
 243 M: condition error. error>> error. ;
 244
 245 M: condition summary error>> summary ;
 246
 247 M: condition error-help error>> error-help ;
 248
 249 M: assert summary drop "Assertion failed" ;
 250
 251 M: assert-sequence summary drop "Assertion failed" ;
 252
 253 M: assert-sequence error.
 254     standard-table-style [
 255         [ "=== Expected:" print expected>> stack. ]
 256         [ "=== Got:" print got>> stack. ] bi
 257     ] tabular-output ;
 258
 259 M: immutable summary drop "Sequence is immutable" ;
 260
 261 M: redefine-error error.
 262     "Re-definition of " write
 263     def>> . ;
 264
 265 M: undefined-word summary
 266     word>> undefined-word?
 267     "Cannot execute a deferred word before it has been defined"
 268     "Cannot execute a word before it has been compiled"
 269     ? ;
 270
 271 M: no-compilation-unit error.
 272     "Attempting to define " write
 273     definition>> pprint
 274     " outside of a compilation unit" print ;
 275
 276 M: no-vocab summary
 277     drop "Vocabulary does not exist" ;
 278
 279 M: encode-error summary drop "Character encoding error" ;
 280
 281 M: decode-error summary drop "Character decoding error" ;
 282
 283 M: bad-create summary drop "Bad parameters to create" ;
 284
 285 M: cannot-be-inline summary drop "This type of word cannot be inlined" ;
 286
 287 M: attempt-all-error summary drop "Nothing to attempt" ;
 288
 289 M: already-disposed summary drop "Attempting to operate on disposed object" ;
 290
 291 M: no-current-vocab-error summary
 292     drop "Not in a vocabulary; IN: form required" ;
 293
 294 M: no-word-error summary
 295     name>>
 296     "No word named “"
 297     "” found in current vocabulary search path" surround ;
 298
 299 M: no-word-error error. summary print ;
 300
 301 M: no-word-in-vocab summary
 302     [ vocab>> ] [ word>> ] bi
 303     [ "No word named “" % % "” found in “" % % "” vocabulary" % ] "" make ;
 304
 305 M: no-word-in-vocab error. summary print ;
 306
 307 M: ambiguous-use-error summary
 308     name>>
 309     "The name “" "” resolves to more than one word." surround ;
 310
 311 M: ambiguous-use-error error. summary print ;
 312
 313 M: staging-violation summary
 314     drop
 315     "A parsing word cannot be used in the same file it is defined in." ;
 316
 317 M: bad-number summary
 318     drop "Bad number literal" ;
 319
 320 M: duplicate-slot-names summary
 321     drop "Duplicate slot names" ;
 322
 323 M: invalid-slot-name summary
 324     drop "Invalid slot name" ;
 325
 326 M: bad-inheritance summary
 327     drop "Circularity in inheritance chain" ;
 328
 329 M: not-in-a-method-error summary
 330     drop "call-next-method can only be called in a method definition" ;
 331
 332 M: version-control-merge-conflict summary
 333     drop "Version control merge conflict in source code" ;
 334
 335 GENERIC: expected>string ( obj -- str )
 336
 337 M: f expected>string drop "end of input" ;
 338 M: word expected>string name>> ;
 339 M: string expected>string ;
 340
 341 M: unexpected error.
 342     "Expected " write
 343     dup want>> expected>string write
 344     " but got " write
 345     got>> expected>string print ;
 346
 347 M: lexer-error error.
 348     [ lexer-dump ] [ error>> error. ] bi ;
 349
 350 M: lexer-error summary
 351     error>> summary ;
 352
 353 M: lexer-error compute-restarts
 354     [ error-continuation get swap compute-fixups ] [ error>> compute-restarts ] bi append ;
 355
 356 M: lexer-error error-help
 357     error>> error-help ;
 358
 359 M: bad-effect summary
 360     drop "Bad stack effect declaration" ;
 361
 362 M: invalid-row-variable summary
 363     drop "Stack effect row variables can only occur as the first input or output" ;
 364
 365 M: row-variable-can't-have-type summary
 366     drop "Stack effect row variables cannot have a declared type" ;
 367
 368 M: bad-escape error.
 369     "Bad escape code: \\" write char>> write nl ;
 370
 371 M: bad-literal-tuple summary drop "Bad literal tuple" ;
 372
 373 M: not-found-in-roots summary
 374     path>> "Cannot resolve vocab: " prepend ;
 375
 376 M: wrong-values summary drop "Quotation's stack effect does not match call site" ;
 377
 378 M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;
 379
 380 M: callsite-not-compiled summary
 381     drop "Caller not compiled with the optimizing compiler" ;
 382
 383 { "threads" "debugger" } "debugger.threads" require-when
 384
 385 os unix? [ "debugger.unix" require ] when