basis/debugger/debugger.factor

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