# (c) 2021 Ashok P. Nadkarni
# See LICENSE for license terms.
#
# Tests for the cffi::arena command

source [file join [file dirname [info script]] common.tcl]

namespace eval cffi::test {
    testsubcmd ::cffi::arena

    ###
    testnumargs arena-pushframe "cffi::arena pushframe" "" "?SIZE ?TAG??"
    testnumargs arena-popframe "cffi::arena popframe" "" ""

    test arena-pushpopframe-0 "Push and pop a frame" -body {
        list [cffi::arena pushframe] [cffi::arena popframe]
    } -result [list {} {}]

    test arena-pushpopframe-1 "Push one pop twice" -body {
        cffi::arena pushframe
        list [cffi::arena validate] \
            [cffi::arena popframe] [cffi::arena validate] \
            [catch {cffi::arena popframe} msg] $msg [cffi::arena validate]
    } -result [list {} {} {} 1 {Internal error: attempt to pop frame in empty arena.} {}]

    test arena-pushpopframe-2 "Push frame with size" -body {
        set p [cffi::arena pushframe 10]
        set result [list [cffi::pointer isvalid $p] [cffi::arena popframe] [cffi::pointer list]]
    } -result {1 {} {}}

    test arena-pushpopframe-3 "Push frame with size and tag" -body {
        set p [cffi::arena pushframe 10 TAG]
        set result [list [cffi::pointer tag $p] [cffi::pointer isvalid $p] [cffi::arena popframe] [cffi::pointer list]]
    } -result {::cffi::test::TAG 1 {} {}}

    test arena-pushpopframe-4 "Push multiple frames" -body {
        set p [cffi::arena pushframe 10]
        set q [cffi::arena pushframe 10]
        set result [list [cffi::arena validate] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] \
                        [cffi::arena popframe] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] \
                        [cffi::arena popframe] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] \
                        [cffi::arena validate] \
                        [cffi::pointer list]]
    } -result {{} 1 1 {} 1 0 {} 0 0 {} {}}

    foreach {type val} [array get testValues] {
        if {$type ni {string unistring winstring binary}} {
            test arena-pushframe-$type-0 "pushframe $type" -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena pushframe $type]
                cffi::memory set $p $type $val
                cffi::memory get $p $type
            } -result $val
            if {$type in [list {*}$numericTypes struct.::StructValue]} {
                # In array tests, use [lindex $type 0] since testValues contains
                # "pointer unsafe" and we only want pointer
                test arena-pushframe-$type-array-0 "pushframe $type array" -cleanup {
                    cffi::arena popframe
                } -body {
                    set p [cffi::arena pushframe $type\[2\]]
                    cffi::memory set $p $type\[2\] [list $val $val]
                    cffi::memory get $p $type\[2\]
                } -result [list $val $val]
            }
        }
    }

    test arena-pushframe-error-0 {pushframe zero bytes} -body {
        list [catch {cffi::arena pushframe 0} result] $result $::errorCode
    } -result {1 {Invalid value "0". Allocation size argument must be a positive integer or a fixed size type specification.} {cffi INVALID_VALUE {Invalid value "0". Allocation size argument must be a positive integer or a fixed size type specification.}}}

    test arena-pushframe-badtype-0 "pushframe bad type" -body {
        cffi::arena pushframe badtype
    } -result {Invalid value "badtype". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error

    test arena-pushframe-badtype-1 "pushframe bad type - void" -body {
        cffi::arena pushframe void
    } -result {Invalid value "void". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error

    test arena-pushframe-badtype-2 "pushframe varsize" -setup {
        cffi::Struct create S {n int a uchar[n]}
    } -cleanup {
        S destroy
    } -body {
        cffi::arena pushframe struct.S
    } -result {Invalid value "struct.S". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error


    ### allocate

    testnumargs arena-allocate "cffi::arena allocate" "SIZE" "?TAG?"

    test arena-allocate-0 "Allocate without tag" -setup {
        cffi::arena pushframe
    } -cleanup {
        cffi::arena popframe
    } -body {
        set p [cffi::arena allocate 1]
        list [cffi::pointer isvalid $p] [cffi::pointer tag $p]
    } -result {1 {}}

    test arena-allocate-1 "Allocate with tag" -setup {
        cffi::arena pushframe
    } -cleanup {
        cffi::arena popframe
    } -body {
        set p [cffi::arena allocate 1 TAG]
        list [cffi::pointer isvalid $p] [cffi::pointer tag $p]
    } -result {1 ::cffi::test::TAG}

    test arena-allocate-2 "Multipl frames and allocations" -body {
        cffi::arena pushframe
        set p [cffi::arena allocate 1]
        set q [cffi::arena allocate 1]
        cffi::arena pushframe
        set r [cffi::arena allocate 1]
        set result [list [cffi::arena validate] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] [cffi::pointer isvalid $r] \
                        [cffi::arena popframe] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] [cffi::pointer isvalid $r] \
                        [cffi::arena popframe] \
                        [cffi::pointer isvalid $p] [cffi::pointer isvalid $q] [cffi::pointer isvalid $r] \
                        [cffi::arena validate] \
                        [cffi::pointer list]]
    } -result {{} 1 1 1 {} 1 1 0 {} 0 0 0 {} {}}

    foreach {type val} [array get testValues] {
        if {$type ni {string unistring winstring binary}} {
            test arena-allocate-$type-0 "allocate $type" -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena allocate $type]
                cffi::memory set $p $type $val
                cffi::memory get $p $type
            } -result $val
            if {$type in [list {*}$numericTypes struct.::StructValue]} {
                # In array tests, use [lindex $type 0] since testValues contains
                # "pointer unsafe" and we only want pointer
                test arena-allocate-$type-array-0 "allocate $type array" -setup {
                    cffi::arena pushframe
                } -cleanup {
                    cffi::arena popframe
                } -body {
                    set p [cffi::arena allocate $type\[2\]]
                    cffi::memory set $p $type\[2\] [list $val $val]
                    cffi::memory get $p $type\[2\]
                } -result [list $val $val]
            }
        }
    }

    test arena-allocate-error-0 {Allocate zero bytes} -body {
        list [catch {cffi::arena allocate 0} result] $result $::errorCode
    } -result {1 {Invalid value "0". Allocation size argument must be a positive integer or a fixed size type specification.} {cffi INVALID_VALUE {Invalid value "0". Allocation size argument must be a positive integer or a fixed size type specification.}}}

    test arena-allocate-badtype-0 "allocate bad type" -body {
        cffi::arena allocate badtype
    } -result {Invalid value "badtype". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error

    test arena-allocate-badtype-1 "allocate bad type - void" -body {
        cffi::arena allocate void
    } -result {Invalid value "void". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error

    test arena-allocate-badtype-2 "allocate varsize" -setup {
        cffi::Struct create S {n int a uchar[n]}
    } -cleanup {
        S destroy
    } -body {
        cffi::arena allocate struct.S
    } -result {Invalid value "struct.S". Allocation size argument must be a positive integer or a fixed size type specification.} -returnCodes error

    #
    # new
    testnumargs allocate-new "cffi::arena new" "TYPE INITIALIZER" "?TAG?"

    foreach {type val} [array get testValues] {
        if {$type ni {string unistring winstring binary}} {
            test arena-new-$type-0 "new $type" -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena new $type $val]
                list [cffi::memory get $p $type] [cffi::pointer isvalid $p] [cffi::pointer tag $p]
            } -result [list $val 1 {}]
            test arena-new-$type-1 "new $type with tag" -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena new $type $val TAG]
                list [cffi::memory get $p $type] [cffi::pointer isvalid $p] [cffi::pointer tag $p]
            } -result [list $val 1 [namespace current]::TAG]
            test arena-new-$type-2 "new $type with qualified tag" -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena new $type $val ::ns::TAG]
                list [cffi::memory get $p $type] [cffi::pointer isvalid $p] [cffi::pointer tag $p]
            } -result [list $val 1 ::ns::TAG]
            test arena-new-$type-alias-0 "new $type aliased" -setup {
                cffi::alias clear
                cffi::alias define ALIAS $type
                cffi::arena pushframe
            } -cleanup {
                cffi::alias clear
                cffi::arena popframe
            } -body {
                set p [cffi::arena new ALIAS $val]
                list [cffi::memory get $p $type] [cffi::pointer isvalid $p] [cffi::pointer tag $p]
            } -result [list $val 1 {}]
        }
        if {$type in $numericTypes} {
            test arena-new-$type-array-0 "new $type array"  -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena new $type\[2\] [list 1 $val]]
                cffi::memory get $p $type\[2\]
            } -result [list [expr {$type in $realTypes ? 1.0 : 1}] $val]
            test arena-new-$type-array-1 "new $type array fill extra elements with zeroes"  -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                set p [cffi::arena new $type\[4\] [list 1 $val]]
                cffi::memory get $p $type\[4\]
            } -result [expr {$type in $realTypes? [list 1.0 $val 0.0 0.0] : [list 1 $val 0 0]}]
        }
        if {[info exists badValues($type)]} {
            test arena-new-$type-badvalue-0 "new $type bad value" -setup {
                cffi::arena pushframe
            } -cleanup {
                cffi::arena popframe
            } -body {
                cffi::arena new $type $badValues($type)
            } -result {expected.*but got|Invalid value|missing.*key} -returnCodes error -match regexp
        }
    }
    
}

::tcltest::cleanupTests
namespace delete cffi::test
