! Copyright (C) 2004, 2007 Slava Pestov.
! See http://factorcode.org/license.txt for BSD license.
IN: kernel-internals
USING: arrays generic namespaces sequences math assocs ;

: >c ( continuation -- ) catchstack* push ;
: c> ( -- continuation ) catchstack* pop ;

IN: errors
USING: kernel ;

SYMBOL: error
SYMBOL: error-continuation
SYMBOL: error-stack-trace
SYMBOL: restarts

GENERIC: compute-restarts ( error -- seq )

: save-error ( error -- )
    dup error set-global
    compute-restarts restarts set-global ;

: catch ( try -- error/f )
    [ >c call f c> drop f ] callcc1 nip ; inline

: rethrow ( error -- )
    catchstack* empty?
    [ die ] [ dup save-error c> continue-with ] if ;

: cleanup ( try cleanup -- )
    [ >c >r call c> drop r> call ]
    [ >r nip call r> rethrow ] ifcc ;
    inline

: recover ( try recovery -- )
    [ >c drop call c> drop ]
    [ rot drop swap call ] ifcc ; inline

TUPLE: condition restarts continuation ;

C: condition ( error restarts cc -- condition )
    [ set-condition-continuation ] keep
    [ set-condition-restarts ] keep
    [ set-delegate ] keep ;

: throw-restarts ( error restarts -- restart )
    [ <condition> throw ] callcc1 2nip ;

: rethrow-restarts ( error restarts -- restart )
    [ <condition> rethrow ] callcc1 2nip ;

TUPLE: restart name obj continuation ;

: restart ( restart -- )
    dup restart-obj swap restart-continuation continue-with ;

M: object compute-restarts drop { } ;

M: tuple compute-restarts delegate compute-restarts ;

M: condition compute-restarts
    [ delegate compute-restarts ] keep
    [ condition-continuation ] keep
    condition-restarts [ first2 rot <restart> ] map-with
    append ;

PREDICATE: array kernel-error ( obj -- ? )
    {
        { [ dup empty? ] [ drop f ] }
        { [ dup first \ kernel-error eq? not ] [ drop f ] }
        { [ t ] [ second 0 19 between? ] }
    } cond ;

TUPLE: assert got expect ;

: assert ( got expect -- * ) <assert> throw ;

: assert= ( a b -- ) 2dup = [ 2drop ] [ assert ] if ;

: assert-depth ( quot -- ) depth slip depth swap assert= ;

DEFER: try