#  (C) Copyright David Abrahams 2001. Permission to copy, use, modify, sell and
#  distribute this software is granted provided this copyright notice appears in
#  all copies. This software is provided "as is" without express or implied
#  warranty, and with no claim as to its suitability for any purpose.

# Print a stack backtrace leading to this rule's caller. Each
# argument represents a line of output to be printed after the first
# line of the backtrace.
rule backtrace ( skip-frames messages * : * )
{
    local frame-skips = 5 9 13 17 21 25 29 33 37 41 45 49 53 57 61 65 69 73 77 81 ;
    local drop-elements = $(frame-skips[$(skip-frames)]) ;
    if ! ( $(skip-frames) in 1 2 3 4 5 6 7 8 9 10 11 12 13 14 15 16 17 18 19 20 )
    {
        ECHO warning: backtrace doesn't support skipping
          $(skip-frames) frames; using 1 instead. ;
        drop-elements = 5 ;
    }
    
    # get the whole backtrace, then drop the initial quadruples
    # corresponding to the frames that must be skipped.
    local bt = [ BACKTRACE ] ;
    bt = $(bt[$(drop-elements)-]) ; 
    
    local args = $(.args) ;
    while $(bt)
    {
        local m = [ MATCH ^(.+)\\.$ : $(bt[3]) ] ;
        ECHO $(bt[1]):$(bt[2]): "in" $(bt[4]) "from module" $(m) ;
        
        # the first time through, print each argument on a separate
        # line
        for local n in $(args)
        {
            if $($(n))-is-not-empty
            {
                ECHO $($(n)) ;
            }
        }
        args = ; # kill args so that this never happens again
        
        # Move on to the next quadruple
        bt = $(bt[5-]) ;
    }
}

.args ?= messages 2 3 4 5 6 7 8 9 ;
.disabled ?= ;
.last-$(.args) ?= ;

# try-catch --
#
# This is not really an exception-handling mechanism, but it does
# allow us to perform some error-checking on our
# error-checking. Errors are suppressed after a try, and the first one
# is recorded. Use catch to check that the error message matched
# expectations.

# begin looking for error messages
rule try ( )
{
    .disabled += true ;
    .last-$(.args) = ;
}

# stop looking for error messages; generate an error if an argument of
# messages is not found in the corresponding argument in the error call.
rule catch ( messages * : * )
{
    import sequence ;
    .disabled = $(.disabled[2-]) ; # pop the stack

    for local n in $(.args)
    {
        if ! $($(n)) in $(.last-$(n))
        {
            local v = [ sequence.join $($(n)) : " " ] ;
            v ?= "" ;
            local joined = [ sequence.join $(.last-$(n)) : " " ] ;
            
            .last-$(.args) = ;
            error-skip-frames 3 expected \"$(v)\" in argument $(n) of error
              : got \"$(joined)\" instead ;
        }
    }
}

rule error-skip-frames ( skip-frames messages * : * )
{
    if ! $(.disabled)
    {
        backtrace $(skip-frames) error: $(messages) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
        EXIT ;
    }
    else if ! $(.last-$(.args))
    {
        for local n in $(.args)
        {
            .last-$(n) = $($(n)) ;
        }
    }
}

# Print an error message with a stack backtrace and exit.
rule error ( messages * : * )
{
    error-skip-frames 3 $(1) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
}

# Print a warning message with a stack backtrace and exit.
rule warning
{
    backtrace 2 warning: $(1) : $(2) : $(3) : $(4) : $(5) : $(6) : $(7) : $(8) : $(9) ;
}

# convert an arbitrary argument list into a list with ":" separators
# and quoted elements representing the same information. This is
# mostly useful for formatting descriptions of the arguments with
# which a rule was called when reporting an error.
rule lol->list ( * )
{
    local result ;
    local remaining = 1 2 3 4 5 6 7 8 9 ;
    while $($(remaining))
    {
        local n = $(remaining[1]) ;
        remaining = $(remaining[2-]) ;
        
        if $(n) != 1
        {
            result += ":" ;
        }
        result += \"$($(n))\" ;
    }
    return $(result) ;
}

rule __test__ ( )
{
    # show that we can correctly catch an expected error
    try ;
    {
        error an error occurred : somewhere ;
    }
    catch an error occurred : somewhere ;
    
    # show that unexpected errors generate real errors
    try ;
    {
        try ;
        {
            error an error occurred : somewhere ;
        }
        catch an error occurred : nowhere ;
    }
    catch expected \"nowhere\" in argument 2 ;
}