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