path: root/gcc/testlib/elna-dg.exp

#   Copyright (C) 2004-2025 Free Software Foundation, Inc.

# This program is free software; you can redistribute it and/or modify
# it under the terms of the GNU General Public License as published by
# the Free Software Foundation; either version 3 of the License, or
# (at your option) any later version.
#
# This program is distributed in the hope that it will be useful,
# but WITHOUT ANY WARRANTY; without even the implied warranty of
# MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
# GNU General Public License for more details.
#
# You should have received a copy of the GNU General Public License
# along with GCC; see the file COPYING3.  If not see
# <http://www.gnu.org/licenses/>.

load_lib gcc-dg.exp

# Define elna callbacks for dg.exp.

proc elna-dg-test { prog do_what extra_tool_flags } {
    set result \
    [gcc-dg-test-1 elna_target_compile $prog $do_what $extra_tool_flags]

    set comp_output [lindex $result 0]
    set output_file [lindex $result 1]

    return [list $comp_output $output_file]
}

proc elna-dg-prune { system text } {
    return [gcc-dg-prune $system $text]
}

# Utility routines.

#
# Escapes a directive argument so that it reaches dejagnu intact.
#
# dg.exp evaluates each extracted directive as a Tcl script
# ("catch $op"), which performs one round of backslash, command and
# variable substitution inside the double-quoted argument. Quoting the
# affected characters here means the argument dejagnu receives is
# exactly what the test author wrote, so @Error messages keep their
# regular expression semantics: "\[2\]" matches literal brackets and
# "[2]" stays a character class.
#
proc elna-escape-directive { text } {
    return [string map [list \
        "\\" "\\\\" \
        "\[" "\\\[" \
        "\]" "\\\]" \
        "\$" "\\\$" \
        "\"" "\\\""] $text]
}

#
# Replaces an elna-native directive in the line with its dg-* equivalent,
# escaping the directive argument for dejagnu's Tcl evaluation.
#
# line_var  - name of the variable holding the line in the caller.
# directive - elna directive name, e.g. @Error.
# dg_name   - dejagnu directive name, e.g. dg-error.
#
proc elna-convert-directive { line_var directive dg_name } {
    upvar 1 $line_var line

    if { [regexp -indices "\\(\\*\\s*$directive\\s+(.*?)\\s*\\*\\)" $line whole argument] } {
        set escaped [elna-escape-directive \
            [string range $line [lindex $argument 0] [lindex $argument 1]]]
        set prefix [string range $line 0 [expr {[lindex $whole 0] - 1}]]
        set suffix [string range $line [expr {[lindex $whole 1] + 1}] end]

        set line "${prefix}(* { $dg_name \"$escaped\" } *)$suffix"
    }
}

#
# This procedure copies a test file from the source tree to the
# build directory while rewriting elna-native directives to dejagnu
# dg-* equivalents.
#
# Directives (inside (* ... *) comments):
#
#   (* @Error message *)      Expected compiler error on this line.
#   (* @Flags args *)         Extra compiler flags.
#
# base - absolute path to the source directory, e.g. .../testsuite/elna.dg
# test - relative path from testsuite, e.g. fail_compilation/file_name.elna
#
#
# Creates a directory at $path, handling the case where a regular
# file already exists at that location (leftover from a prior
# interrupted run).
#
proc elna-ensure-dir { path } {
    if { [file exists $path] && ![file isdirectory $path] } {
        file delete $path
    }
    file mkdir $path
}

proc elna-convert-test { base test { extra_lines "" } } {
    set type [file dirname $test]
    set target $test

    # Opens a file in the build directory for writing and the source
    # file for reading.
    elna-ensure-dir $type
    set fin [open $base/$target r]
    set fout [open $target w]

    # Reads the source test file line by line and replace directives with
    # Elna equivalents using a regular expression.
    while { [gets $fin line] >= 0 } {
        elna-convert-directive line @Error dg-error
        elna-convert-directive line @Flags dg-additional-options
        puts $fout $line
    }

    close $fin

    # Append caller-supplied extra directives (e.g. dg-additional-sources).
    foreach line $extra_lines {
        puts $fout $line
    }

    # Suppress excess output so stray diagnostics do not fail the test.
    puts $fout "(* { dg-prune-output .* } *)"

    # Emit category-specific expectation.
    set category [lindex [file split $test] 0]
    switch $category {
        compilable {
            # Assert that an output file was produced.
            puts $fout "(* { dg-final { output-exists } } *)"
        }
        fail_compilation {
            # Assert that no output file was produced.
            puts $fout "(* { dg-final { output-exists-not } } *)"
        }
        # Other cases are handled automatically.
    }

    close $fout

    # Reaches up one stack frame (into the runtest proc) and links the
    # caller's cleanup_extra_files variable to the local name cleanups.
    upvar 1 cleanup_extra_files cleanups
    # This ensures the converted file gets deleted after the test runs.
    lappend cleanups $target

    return $target
}

#
# Handles a multi-module test directory.
#
# Requires sut.elna (system under test) as the primary module;
# all other .elna files are passed as dg-additional-sources.
#
# base - absolute path to the source directory.
# test - relative path from testsuite, e.g. group/test_name.
#
proc elna-handle-multimodule { base test } {
    upvar 1 cleanup_extra_files cleanups

    set dir "$base/$test"

    # Find all .elna files recursively inside the test directory.
    set modules [lsort [find $dir *.elna]]
    if { [llength $modules] == 0 } {
        return ""
    }

    # Allocate sut.elna as the primary module, collect the rest.
    set main_module ""
    set extra_sources ""
    foreach module $modules {
        if { [file tail $module] == "sut.elna" } {
            set main_module $module
        } else {
            lappend extra_sources $module
        }
    }
    if { $main_module == "" } {
        error "multi-module test directory \"$test\" must contain sut.elna"
    }

    # Build extra directives: -I for imports and dg-additional-sources.
    set extra_lines ""
    lappend extra_lines "(* { dg-additional-options \"-I$dir\" } *)"
    elna-ensure-dir $test
    foreach src $extra_sources {
        set src_rel [string range $src [expr {[string length $dir] + 1}] end]
        file copy $src $test
        lappend cleanups [file join $test $src_rel]
        lappend extra_lines "(* { dg-additional-sources \"$src_rel\" } *)"
    }

    # Convert the primary module, passing the extra directives.
    set main_rel [file join $test [file tail $main_module]]
    return [elna-convert-test $base $main_rel $extra_lines]
}

#
# Runs a converted test file through dejagnu and cleans up afterwards.
#
proc elna-dg-run-one { target type cleanup_extra_files } {
    global dg-do-what-default

    switch $type {
        runnable { set dg-do-what-default "run" }
        default  { set dg-do-what-default "compile" }
    }

    dg-test $target "" ""
    file delete $target
    foreach srcfile $cleanup_extra_files {
        file delete $srcfile
    }
}

#
# Converts and runs single-module .elna test files.
#
proc elna-dg-runtest-single { testcases } {
    global dg-do-what-default
    set saved-dg-do-what-default ${dg-do-what-default}

    foreach test $testcases {
        set type [file tail [file dirname $test]]
        set name [file tail $test]
        set base [file dirname [file dirname $test]]
        set cleanup_extra_files ""

        set target [elna-convert-test $base $type/$name]
        elna-dg-run-one $target $type $cleanup_extra_files
    }

    set dg-do-what-default ${saved-dg-do-what-default}
}

#
# Converts and runs multi-module test directories.
#
proc elna-dg-runtest-multi { testcases } {
    global dg-do-what-default
    set saved-dg-do-what-default ${dg-do-what-default}

    foreach test $testcases {
        set type [file tail [file dirname $test]]
        set name [file tail $test]
        set base [file dirname [file dirname $test]]
        set cleanup_extra_files ""

        set target [elna-handle-multimodule $base $type/$name]
        if { $target == "" } {
            continue
        }

        elna-dg-run-one $target $type $cleanup_extra_files
    }

    set dg-do-what-default ${saved-dg-do-what-default}
}