factor/basis/debugger/debugger.factor

! Copyright (C) 2004, 2011 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
USING: accessors alien.strings arrays assocs classes
classes.builtin classes.mixin classes.tuple classes.tuple.parser
combinators combinators.short-circuit compiler.errors
compiler.units continuations definitions destructors
effects.parser fry generic generic.math generic.parser
generic.single grouping io io.encodings io.styles kernel
kernel.private lexer make math math.order math.parser namespaces
parser prettyprint sequences sequences.private slots
source-files.errors strings strings.parser summary system vocabs
vocabs.loader vocabs.parser words ;
FROM: namespaces => change-global ;
IN: debugger

GENERIC: error-help ( error -- topic )

M: object error-help drop f ;

M: tuple error-help class-of ;

M: source-file-error error-help error>> error-help ;

GENERIC: error. ( error -- )

M: object error. short. ;

M: string error. print ;

: traceback-link. ( continuation -- )
    "[" write [ "Traceback" ] dip write-object "]" print ;

: :s ( -- )
    error-continuation get data>> stack. ;

: :r ( -- )
    error-continuation get retain>> stack. ;

: :c ( -- )
    error-continuation get call>> callstack. ;

: :get ( variable -- value )
    error-continuation get name>> assoc-stack ;

: :res ( n -- * )
    1 - restarts [ nth f ] change-global continue-restart ;

: :1 ( -- * ) 1 :res ;
: :2 ( -- * ) 2 :res ;
: :3 ( -- * ) 3 :res ;

: restart. ( restart n -- )
    [
        1 + dup 3 <= [ ":" % # "      " % ] [ # " :res  " % ] if
        name>> %
    ] "" make print ;

: restarts. ( -- )
    restarts get [
        nl
        "The following restarts are available:" print
        nl
        [ restart. ] each-index
    ] unless-empty ;

: print-error ( error -- )
    [ error. flush ] curry
    [ [ "Error in print-error!" print drop ] with-global ]
    recover ;

: :error ( -- )
    error get print-error ;

: print-error-and-restarts ( error -- )
    print-error
    restarts.
    nl
    "Type :help for debugging help." print flush ;

: try ( quot -- )
    [ print-error-and-restarts ] recover ; inline

: expired-error. ( obj -- )
    "Object did not survive image save/load: " write third . ;

: io-error. ( error -- )
    "I/O error #" write third . ;

: type-check-error. ( obj -- )
    "Type check error" print
    "Object: " write dup fourth short.
    "Object type: " write dup fourth class-of .
    "Expected type: " write third type>class . ;

: divide-by-zero-error. ( obj -- )
    "Division by zero" print drop ;

HOOK: signal-error. os ( obj -- )

: array-size-error. ( obj -- )
    "Invalid array size: " write dup third .
    "Maximum: " write fourth 1 - . ;

: fixnum-range-error. ( obj -- )
    "Cannot convert to fixnum: " write third . ;

: c-string-error. ( obj -- )
    "Cannot convert to C string: " write third . ;

: ffi-error. ( obj -- )
    "FFI error" print drop ;

: find-ffi-error ( string -- error )
    [ linkage-errors get ] dip
    '[ nip asset>> name>> _ = ] assoc-find drop nip
    [ error>> message>> ] [ "none" ] if* ;

: undefined-symbol-error. ( obj -- )
    "Cannot resolve C library function" print
    "Library: " write dup fourth .
    third symbol>string
    [ "Symbol: " write print ]
    [ "DlError: " write find-ffi-error print ] bi
    "See http://concatenative.org/wiki/view/Factor/Requirements" print ;

: stack-underflow. ( obj name -- )
    write " stack underflow" print drop ;

: stack-overflow. ( obj name -- )
    write " stack overflow" print drop ;

: datastack-underflow. ( obj -- ) "Data" stack-underflow. ;
: datastack-overflow. ( obj -- ) "Data" stack-overflow. ;
: retainstack-underflow. ( obj -- ) "Retain" stack-underflow. ;
: retainstack-overflow. ( obj -- ) "Retain" stack-overflow. ;
: callstack-underflow. ( obj -- ) "Call" stack-underflow. ;
: callstack-overflow. ( obj -- ) "Call" stack-overflow. ;

: memory-error. ( error -- )
    "Memory protection fault at address " write third .h ;

: primitive-error. ( error -- )
    "Unimplemented primitive" print drop ;

: fp-trap-error. ( error -- )
    "Floating point trap" print drop ;

: interrupt-error. ( error -- )
    "Interrupt" print drop ;

PREDICATE: vm-error < array
    dup length 2 < [ drop f ] [
        {
            [ first-unsafe "kernel-error" = ]
            [ second-unsafe 0 kernel-error-count 1 - between? ]
        } 1&&
    ] if ;

: vm-errors ( error -- n errors )
    second {
        [ expired-error.          ]
        [ io-error.               ]
        [ primitive-error.        ]
        [ type-check-error.       ]
        [ divide-by-zero-error.   ]
        [ signal-error.           ]
        [ array-size-error.       ]
        [ fixnum-range-error.     ]
        [ c-string-error.         ]
        [ ffi-error.              ]
        [ undefined-symbol-error. ]
        [ datastack-underflow.    ]
        [ datastack-overflow.     ]
        [ retainstack-underflow.  ]
        [ retainstack-overflow.   ]
        [ callstack-underflow.    ]
        [ callstack-overflow.     ]
        [ memory-error.           ]
        [ fp-trap-error.          ]
        [ interrupt-error.        ]
    } ; inline

M: vm-error summary drop "VM error" ;

M: vm-error error. dup vm-errors dispatch ;

M: vm-error error-help vm-errors nth first ;

M: no-method summary
    drop "No suitable method" ;

M: no-method error.
    "Generic word " write
    dup generic>> pprint
    " does not define a method for the " write
    dup object>> class-of pprint
    " class." print
    "Dispatching on object: " write object>> short. ;

M: bad-slot-value summary drop "Bad store to specialized slot" ;

M: bad-slot-name summary drop "Bad slot name in object literal" ;

M: no-math-method summary
    drop "No suitable arithmetic method" ;

M: no-next-method summary
    drop "Executing call-next-method from least-specific method" ;

M: inconsistent-next-method summary
    drop "Executing call-next-method with inconsistent parameters" ;

M: check-method-error summary
    drop "Invalid parameters for create-method" ;

M: not-a-tuple summary
    drop "Not a tuple" ;

M: bad-superclass summary
    drop "Tuple classes can only inherit from non-final tuple classes" ;

M: bad-initial-value summary
    drop "Incompatible initial value" ;

M: no-cond summary
    drop "Fall-through in cond" ;

M: no-case summary
    drop "Fall-through in case" ;

M: slice-error summary
    drop "Cannot create slice" ;

M: bounds-error summary drop "Sequence index out of bounds" ;

M: groups-error summary drop "Non positive group size" ;

M: condition error. error>> error. ;

M: condition summary error>> summary ;

M: condition error-help error>> error-help ;

M: assert summary drop "Assertion failed" ;

M: assert-sequence summary drop "Assertion failed" ;

M: assert-sequence error.
    standard-table-style [
        [ "=== Expected:" print expected>> stack. ]
        [ "=== Got:" print got>> stack. ] bi
    ] tabular-output ;

M: immutable summary drop "Sequence is immutable" ;

M: redefine-error error.
    "Re-definition of " write
    def>> . ;

M: undefined-word summary
    word>> undefined-word?
    "Cannot execute a deferred word before it has been defined"
    "Cannot execute a word before it has been compiled"
    ? ;

M: no-compilation-unit error.
    "Attempting to define " write
    definition>> pprint
    " outside of a compilation unit" print ;

M: no-vocab summary
    drop "Vocabulary does not exist" ;

M: encode-error summary drop "Character encoding error" ;

M: decode-error summary drop "Character decoding error" ;

M: bad-create summary drop "Bad parameters to create" ;

M: cannot-be-inline summary drop "This type of word cannot be inlined" ;

M: attempt-all-error summary drop "Nothing to attempt" ;

M: already-disposed summary drop "Attempting to operate on disposed object" ;

M: no-current-vocab-error summary
    drop "Not in a vocabulary; IN: form required" ;

M: no-word-error summary
    name>>
    "No word named “"
    "” found in current vocabulary search path" surround ;

M: no-word-error error. summary print ;

M: no-word-in-vocab summary
    [ vocab>> ] [ word>> ] bi
    [ "No word named “" % % "” found in “" % % "” vocabulary" % ] "" make ;

M: no-word-in-vocab error. summary print ;

M: ambiguous-use-error summary
    words>> first name>>
    "More than one vocabulary defines a word named “" "”" surround ;

M: ambiguous-use-error error. summary print ;

M: staging-violation summary
    drop
    "A parsing word cannot be used in the same file it is defined in." ;

M: bad-number summary
    drop "Bad number literal" ;

M: duplicate-slot-names summary
    drop "Duplicate slot names" ;

M: invalid-slot-name summary
    drop "Invalid slot name" ;

M: bad-inheritance summary
    drop "Circularity in inheritance chain" ;

M: not-in-a-method-error summary
    drop "call-next-method can only be called in a method definition" ;

M: version-control-merge-conflict summary
    drop "Version control merge conflict in source code" ;

GENERIC: expected>string ( obj -- str )

M: f expected>string drop "end of input" ;
M: word expected>string name>> ;
M: string expected>string ;

M: unexpected error.
    "Expected " write
    dup want>> expected>string write
    " but got " write
    got>> expected>string print ;

M: lexer-error error.
    [ lexer-dump ] [ error>> error. ] bi ;

M: lexer-error summary
    error>> summary ;

M: lexer-error compute-restarts
    error>> compute-restarts ;

M: lexer-error error-help
    error>> error-help ;

M: bad-effect summary
    drop "Bad stack effect declaration" ;

M: invalid-row-variable summary
    drop "Stack effect row variables can only occur as the first input or output" ;

M: row-variable-can't-have-type summary
    drop "Stack effect row variables cannot have a declared type" ;

M: bad-escape error.
    "Bad escape code: \\" write char>> write nl ;

M: bad-literal-tuple summary drop "Bad literal tuple" ;

M: check-mixin-class-error summary drop "Not a mixin class" ;

M: not-found-in-roots summary
    path>> "Cannot resolve vocab: " prepend ;

M: wrong-values summary drop "Quotation's stack effect does not match call site" ;

M: stack-effect-omits-dashes summary drop "Stack effect must contain “--”" ;

{ "threads" "debugger" } "debugger.threads" require-when