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