# mcpp-dg.tcl — run mcpp's own cpp-test conformance corpus and score it the way
# DejaGnu does, without DejaGnu.
#
# The corpus (mcpp's cpp-test/test-t and cpp-test/test-l) carries its expected
# results as embedded `{ dg-... }` directives. Upstream scores them with
# DejaGnu's runtest driving gcc; neither runtest nor gcc exists on this target,
# so the scoring below is a direct port of dejagnu-1.6.3 lib/dg.exp's dg-test:
# the same message-matching regsub, the same excess-errors rule, the same
# dg-final evaluation (brace-unescape, build a proc, call it), and the same
# `grep` from lib/utils.exp. The expectations stay upstream's; only the engine
# under them is ours, because upstream's cannot run here.
#
# Two passes, so tclsh never forks:
#   plan  <corpus> <sub> <plandir>   write one "<name>\t<mcpp args>" line per test
#   score <corpus> <sub> <plandir>   read the captures the shell produced, score
#
# The shell in between runs mcpp per plan line. That split exists because Tcl's
# exec is a fork of a large interpreter and this target's per-process memory is
# tight (a late tclsh spawn has been seen to ENOMEM here).

set DG_DEFAULT_FLAGS "-ansi -pedantic-errors"

# gcc flag -> mcpp flag. Every row is mcpp's own documented equivalence, not an
# invention of this harness:
#   -pedantic / -pedantic-errors  "Same as -W7."            (mcpp usage text)
#   -Wall                         warn_level |= (1|16)      (system.c, GNUC arm)
#   -w                            warn_level = 0
#   -std=<S>                      __STDC_VERSION__ via -V   (system.c, GNUC arm)
# The one row that is a judgement is -3: mcpp defaults trigraphs OFF
# (TRIGRAPHS_INIT FALSE) while trigraphs are mandatory in the Standard C mode
# every -ansi/-std= case here asks for, so a standard-conforming selector turns
# them on. -j is unconditional: it is what makes mcpp print bare
# "file:line: error: msg" diagnostics with no source echo and no trailing
# summary (main.c gates both on no_source_line), which is the format the
# corpus's dg-error regexes were written against.
# gcc names source encodings the way iconv does; mcpp has its own short names
# for the ones it knows (-e euc_jp, sjis, utf8, ...). Only the encoding the
# corpus actually asks for is mapped; anything else is passed through so an
# unknown name fails loudly at mcpp rather than being silently dropped here.
proc charset_to_mcpp {cs} {
    switch -- [string toupper $cs] {
        EUC-JP  { return euc_jp }
        SJIS -
        SHIFT-JIS { return sjis }
        UTF-8   { return utf8 }
        default { return [string tolower $cs] }
    }
}

proc map_flags {flags srcfile} {
    set out [list -j]
    set cplus 0
    set std_c 0
    set digr 0
    set warn -1
    foreach f $flags {
        switch -glob -- $f {
            -ansi -
            -std=c89 -
            -std=c90 -
            -std=iso9899:1990   { set std_c 1 }
            -std=iso9899:199409 { set std_c 1; set digr 1; lappend out -V199409L }
            -std=c99 -
            -std=c9x -
            -std=iso9899:1999   { set std_c 1; set digr 1; lappend out -V199901L }
            -std=c++98          { set std_c 1; set digr 1; set cplus 1; lappend out -V199711L }
            -std=gnu*           { }
            -trigraphs          { set std_c 1 }
            -pedantic -
            -pedantic-errors    { if {$warn < 0} {set warn 0}; set warn [expr {$warn | 1 | 2 | 4}] }
            -Wall               { if {$warn < 0} {set warn 0}; set warn [expr {$warn | 1 | 16}] }
            -w                  { set warn 0 }
            -no-integrated-cpp  { }
            -finput-charset=*   { regexp {=(.*)$} $f -> cs
                                  lappend out -e [charset_to_mcpp $cs] }
            default             { }
        }
    }
    # mcpp's -W SETS the level, while gcc's warning selectors accumulate
    # (system.c ORs the bits: pedantic |= 1|2|4, -Wall |= 1|16). So the bits are
    # ORed here and emitted once; two -W options would silently keep only the last.
    if {$warn >= 0} { lappend out -W$warn }
    # gcc selects its C++ front end from the .C suffix; mcpp needs it asked for.
    if {!$cplus && [string match {*.C} $srcfile]} { set cplus 1 }
    if {$cplus} { lappend out -+ }
    if {$std_c} { lappend out -3 }
    # Digraphs entered the language with C90 Amendment 1, so a selector that
    # asks for C94 or later asks for them; mcpp defaults them off
    # (DIGRAPHS_INIT FALSE) and spells the switch -2.
    if {$digr} { lappend out -2 }
    return $out
}

# ---------------------------------------------------------------- directives --
# dg.exp:dg-get-options, verbatim in behaviour: find every line carrying
# "{ dg-NAME ... }" and split it into command / line number / argument text.
proc dg_get_options {path} {
    set result {}
    set fd [open $path r]
    set n 0
    while {[gets $fd line] >= 0} {
        incr n
        if {[regexp {\{[ \t]+(dg-[-a-z]+)[ \t]+(.*)[ \t]+\}[^\}]*$} $line -> cmd args]} {
            lappend result [list $cmd $n $args]
        }
    }
    close $fd
    return $result
}

# The dg-* argument text is Tcl-quoted in the source ("\[^ \]* error:"), and
# dg.exp reaches its value by evaluating the directive as a command. Doing the
# same with `lindex` on the raw text applies Tcl's quote and backslash rules
# without command substitution -- which is what the escaping in the corpus
# (\[ ... \]) is there to prevent in dg.exp too.
proc dg_arg {args_text i} {
    if {[catch {lindex $args_text $i} v]} { return "" }
    return $v
}

# dg.exp:dg-process-target, for the only selector spelling this corpus uses
# (`{ target *-*-* }`, 49 of them, and no xfail at all). Anything else is
# reported rather than silently assumed to select, so a corpus that grows a new
# spelling cannot pass by accident.
proc dg_select {selector} {
    if {$selector eq ""} { return S }
    set kind [lindex $selector 0]
    set triplets [lrange $selector 1 end]
    set hit 0
    foreach t $triplets { if {[string match $t "wasm32-brintos-linux"]} { set hit 1 } }
    if {$kind eq "target"} { return [expr {$hit ? "S" : "N"}] }
    if {$kind eq "xfail"}  { return [expr {$hit ? "F" : "P"}] }
    return "?"
}

# dg.exp:dg-error / dg-warning argument handling: arg 3 is the target/xfail
# selector, arg 4 overrides the line the message is expected on ("0" drops the
# line anchor entirely, which is how a diagnostic reported against an INCLUDED
# file is expressed).
proc dg_message {cmd line args_text} {
    set type [expr {$cmd eq "dg-error" ? "ERROR" : ($cmd eq "dg-warning" ? "WARNING" : "BOGUS")}]
    # dg.exp indexes these one higher because dg-test prepends the line number
    # to the argument list before evaluating the directive; here the line
    # arrives separately, so: 0 pattern, 1 comment, 2 selector, 3 line-override.
    set n [llength $args_text]
    set xfail ""
    if {$n >= 3} {
        switch -- [dg_select [dg_arg $args_text 2]] {
            F { set xfail X }
            P { }
            S { }
            N { return "" }
            default { return [list -1 UNKNOWN-SELECTOR [dg_arg $args_text 2] "" $line] }
        }
    }
    set fline ":$line:"
    if {$n >= 4} {
        set spec [dg_arg $args_text 3]
        if {$spec eq "."} {
            set fline ":$line:"
        } elseif {$spec eq "0"} {
            set fline ""
        } else {
            set fline ":$spec:"
        }
    }
    return [list $fline ${xfail}$type [dg_arg $args_text 0] [dg_arg $args_text 1] $line]
}

proc parse_test {path} {
    global DG_DEFAULT_FLAGS
    set do compile
    set flags $DG_DEFAULT_FLAGS
    set messages {}
    set excess 0
    set final ""
    set bad {}
    foreach op [dg_get_options $path] {
        lassign $op cmd line args
        switch -- $cmd {
            dg-do       { set do [dg_arg $args 0] }
            dg-options  { set flags [dg_arg $args 0] }
            dg-error -
            dg-warning -
            dg-bogus    { set m [dg_message $cmd $line $args]
                          if {$m ne ""} { lappend messages $m } }
            dg-excess-errors { set excess 1 }
            dg-final    { append final "[dg_arg $args 0]\n" }
            default     { lappend bad $cmd }
        }
    }
    return [dict create do $do flags $flags messages $messages \
                        excess $excess final $final bad $bad]
}

proc test_files {corpus sub} {
    set out {}
    foreach ext {c C} {
        foreach f [lsort [glob -nocomplain [file join $corpus $sub *.$ext]]] {
            # *.c.gcc2 / *.c.gcc3 are alternates upstream links into place; the
            # glob above cannot see them, and their live name is already listed.
            lappend out $f
        }
    }
    return [lsort $out]
}

# --------------------------------------------------------------------- plan --
proc do_plan {corpus sub plandir} {
    set fd [open [file join $plandir plan.txt] w]
    foreach f [test_files $corpus $sub] {
        set t [parse_test $f]
        set base [file rootname [file tail $f]]
        set args [map_flags [dict get $t flags] $f]
        # dg-do run needs a compiler and a loader; neither exists on this
        # target. Planned as skip rather than dropped, so the count still adds up.
        set kind [dict get $t do]
        puts $fd "$sub/[file tail $f]\t$base\t$kind\t$args"
    }
    close $fd
}

# -------------------------------------------------------------------- score --
# dejagnu lib/utils.exp:grep, reduced to the two forms the corpus uses.
proc grep {args} {
    set options [list]
    if {[lindex $args 0] eq "-n"} { lappend options line; set args [lrange $args 1 end] }
    set file [lindex $args 0]
    set pattern [lindex $args 1]
    if {[llength $args] > 2} { set options [concat $options [lrange $args 2 end]] }
    set grep_out {}
    if {[catch {open $file r} fd]} { return "" }
    set i 0
    while {[gets $fd cur_line] >= 0} {
        incr i
        if {[regexp -- $pattern $cur_line match]} {
            if {[llength $options] > 0} {
                lappend grep_out [concat $i $match]
            } else {
                lappend grep_out $match
            }
        }
    }
    close $fd
    return $grep_out
}

# The two verdict procs the corpus's dg-final fragments call. Upstream's
# fragments only ever call `fail`, so a block that returns quietly is a pass.
proc fail {msg} { lappend ::FINAL_FAILS $msg }
proc pass {msg} { }

set ::FINAL_FAILS {}

proc emit {verdict name {why ""}} {
    if {$why eq ""} {
        puts "$verdict: $name"
    } else {
        puts "$verdict: $name $why"
    }
}

proc do_score {corpus sub plandir} {
    set nfile 0; set npass 0; set nfail 0; set nskip 0
    set fd [open [file join $plandir plan.txt] r]
    set plan {}
    while {[gets $fd line] >= 0} { if {$line ne ""} { lappend plan $line } }
    close $fd

    foreach row $plan {
        set parts [split $row \t]
        set name [lindex $parts 0]
        set base [lindex $parts 1]
        set kind [lindex $parts 2]
        set src  [file join $corpus $sub [file tail $name]]
        incr nfile
        set t [parse_test $src]

        foreach b [dict get $t bad] {
            emit FAIL "$name/unknown-directive:$b"
            incr nfail
        }

        if {$kind ne "preprocess"} {
            # dg-do run/compile: needs a C compiler on the target, which this
            # image does not ship. Reported per expectation so the totals stay
            # comparable with a host run.
            foreach m [dict get $t messages] {
                emit SKIP "$name/[string tolower [lindex $m 1]]@[lindex $m 4]" "needs a target C compiler (dg-do $kind)"
                incr nskip
            }
            emit SKIP "$name/excess-errors" "needs a target C compiler (dg-do $kind)"
            incr nskip
            if {[dict get $t final] ne ""} {
                emit SKIP "$name/dg-final" "needs a target C compiler (dg-do $kind)"
                incr nskip
            }
            continue
        }

        set errfile [file join $plandir $base.err]
        if {![file exists $errfile]} {
            emit FAIL "$name/ran" "no capture: mcpp was never run for this test"
            incr nfail
            continue
        }
        set fh [open $errfile r]
        set comp_output [read $fh]
        close $fh

        # dg.exp: strip the leading directory noise the way dg-test's callers do
        # -- mcpp prints the path it was given, and the corpus's regexes only
        # ever anchor on ":<line>:", so nothing here depends on the spelling.
        foreach m [dict get $t messages] {
            lassign $m fline type pattern comment srcline
            if {$type eq "UNKNOWN-SELECTOR"} {
                emit FAIL "$name/selector@$comment" "unhandled dg selector: $pattern"
                incr nfail
                continue
            }
            set hit [regsub -all "(^|\n)(\[^\n\]+$fline\[^\n\]*($pattern)\[^\n\]*\n?)+" $comp_output "\n" comp_output]
            if {$hit} { set comp_output [string trimleft $comp_output] }
            set cname "$name/[string tolower $type]@$srcline"
            switch -- $type {
                BOGUS {
                    if {$hit} { emit FAIL $cname "bogus message present"; incr nfail } \
                         else { emit PASS $cname; incr npass }
                }
                XERROR - XWARNING {
                    emit SKIP $cname "dg xfail selector"; incr nskip
                }
                default {
                    if {$hit} { emit PASS $cname; incr npass } \
                         else { emit FAIL $cname "expected $type not issued"; incr nfail }
                }
            }
        }

        regsub -all "\n+" $comp_output "\n" comp_output
        regsub "^\n+" $comp_output "" comp_output
        set comp_output [string trim $comp_output]
        set cname "$name/excess-errors"
        if {[dict get $t excess]} {
            # dg.exp setup_xfail: an excess-errors failure here is expected, so
            # it is neither a pass nor a failure. XFAIL has no BST spelling; skip
            # carries the same "not a verdict on the port" meaning.
            emit SKIP $cname "dg-excess-errors: expected excess output (xfail)"
            incr nskip
        } elseif {$comp_output eq ""} {
            emit PASS $cname; incr npass
        } else {
            set first [lindex [split $comp_output \n] 0]
            emit FAIL $cname "excess output: $first"
            incr nfail
        }

        set code [dict get $t final]
        if {$code ne ""} {
            regsub -all {\\([{}])} $code {\1} code
            set ::FINAL_FAILS {}
            proc dg-final-proc {args} $code
            set cname "$name/dg-final"
            if {[catch {dg-final-proc $src} errmsg]} {
                emit FAIL $cname "error executing dg-final: $errmsg"
                incr nfail
            } elseif {[llength $::FINAL_FAILS]} {
                emit FAIL $cname [lindex $::FINAL_FAILS 0]
                incr nfail
            } else {
                emit PASS $cname
                incr npass
            }
        }
    }
    puts "INFO: mcpp-dg sub=$sub files=$nfile pass=$npass fail=$nfail skip=$nskip total=[expr {$npass+$nfail+$nskip}]"
}

# ---------------------------------------------------------------------- main --
set mode [lindex $argv 0]
set corpus [file normalize [lindex $argv 1]]
set sub [lindex $argv 2]
set plandir [file normalize [lindex $argv 3]]
switch -- $mode {
    plan  { do_plan  $corpus $sub $plandir }
    score {
        # dg-final's greps name the .i files by bare basename, so it has to run
        # with the captures as the working directory -- dg-test does the same
        # (`cd [file dirname $prog]`).
        set here [pwd]
        cd $plandir
        do_score $corpus $sub $plandir
        cd $here
    }
    default { puts stderr "usage: mcpp-dg.tcl plan|score <corpus> <sub> <plandir>"; exit 2 }
}