# (c) 2021 Ashok P. Nadkarni
# See LICENSE for license terms.
#
# This file contains tests pertaining to definition and invocation of functions.

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

namespace eval ${NS}::test {

    proc pointer1 {{tag {}}} {
        return [cffi::pointer make 1 $tag]
    }

    proc testnullptr cmd {
        test pointer-$cmd-null-0 "pointer $cmd NULL" -body {
            list [catch {cffi::pointer $cmd [makeptr 0]} result] \
                [string match "Invalid value*Pointer is NULL*" $result]
        } -result {1 1}
        test pointer-$cmd-null-1 "pointer $cmd NULL tagged" -body {
            list [catch {cffi::pointer $cmd [makeptr 0 TAG]} result] \
                [string match "Invalid value*Pointer is NULL*" $result]
        } -result {1 1}
    }
    proc testbadargs {cmd} {
        test pointer-$cmd-badarg-0 "pointer $cmd non-pointer" -body {
            list [catch {cffi::pointer $cmd abc} result] $result $::errorCode
        } -result [list 1 \
                       "Invalid value \"abc\". Invalid pointer format." \
                       [list cffi INVALID_VALUE "Invalid value \"abc\". Invalid pointer format."]]

        test pointer-$cmd-badarg-1 "pointer $cmd empty string" -body {
            list [catch {cffi::pointer $cmd ""} result] $result $::errorCode
        } -result [list 1 \
                       "Invalid value \"\". Invalid pointer format." \
                       [list cffi INVALID_VALUE "Invalid value \"\". Invalid pointer format."]]

        test pointer-$cmd-numargs-0 "pointer $cmd no args" -body {
            cffi::pointer $cmd
        } -result "wrong # args: should be \"cffi::pointer $cmd POINTER\"" -returnCodes error
        test pointer-$cmd-numargs-1 "pointer $cmd too many args" -body {
            cffi::pointer $cmd 0x1^ 0x2^
        } -result "wrong # args: should be \"cffi::pointer $cmd POINTER\"" -returnCodes error
    }

    testsubcmd ::cffi::pointer

    # pointer tag
    testnumargs pointer-tag "pointer tag" POINTER
    testbadargs tag
    test pointer-tag-0 "pointer no tag" -body {
        cffi::pointer tag [makeptr 1]
    } -result ""
    test pointer-tag-1 "pointer tag" -body {
        cffi::pointer tag [makeptr 1 TAG]
    } -result TAG
    test pointer-tag-2 "pointer no tag null pointer " -body {
        cffi::pointer tag [makeptr 0]
    } -result ""
    test pointer-tag-3 "pointer tag null pointer" -body {
        cffi::pointer tag [makeptr 0 TAG]
    } -result TAG

    # pointer check
    testnumargs pointer-check "pointer check" POINTER
    testbadargs check
    testnullptr check
    test pointer-check-0 "pointer check fail" -body {
        list [catch {cffi::pointer check [makeptr 1]} result] \
            [string match "Invalid value \"[makeptr 1]\". Pointer is NULL*" $result]
    } -result {1 1}

    test pointer-check-1 "pointer check success" -setup {
        set ptr [makeptr 1]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer check $ptr
    } -result ""

    test pointer-check-2 "pointer check fail tagged" -body {
        list [catch {cffi::pointer check [makeptr 1 TAG]} result] \
            [string match "Invalid value \"[makeptr 1 TAG]\". Pointer is NULL*" $result]
    } -result {1 1}

    test pointer-check-3 "pointer check success tagged" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer check $ptr
    } -result ""

    test pointer-check-4 "pointer check mismatched tag" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        list [catch {cffi::pointer check [makeptr 1 TAG2]} result] \
            $result \
        } -result [list 1 "Invalid value \"[makeptr 1 TAG2]\". Pointer is NULL or not registered as a valid pointer."]

    test pointer-check-5 "pointer check tagged against registered untagged" -setup {
        set ptr [makeptr 1]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        # Note TAG is always implicitly castable to void so should succeed
        cffi::pointer check [makeptr 1 TAG]
    } -result ""

    test pointer-check-6 "pointer check untagged against registered tagged" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer check [makeptr 1]
    } -result ""

    # pointer isvalid
    testnumargs pointer-isvalid "pointer isvalid" POINTER
    test pointer-isvalid-0 "pointer isvalid fail" -body {
        cffi::pointer isvalid [makeptr 1]
    } -result 0

    test pointer-isvalid-1 "pointer isvalid success" -setup {
        set ptr [makeptr 1]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer isvalid $ptr
    } -result 1

    test pointer-isvalid-2 "pointer isvalid fail tagged" -body {
        cffi::pointer isvalid [makeptr 1 TAG]
    } -result 0

    test pointer-isvalid-3 "pointer isvalid success tagged" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer isvalid $ptr
    } -result 1

    test pointer-isvalid-4 "pointer isvalid mismatched tag" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer isvalid [makeptr 1 TAG2]
    } -result 0

    test pointer-isvalid-5 "pointer isvalid tagged against registered untagged" -setup {
        set ptr [makeptr 1]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        # Note TAG is always implicitly castable to void so should succeed
        cffi::pointer isvalid [makeptr 1 TAG]
    } -result 1

    test pointer-isvalid-6 "pointer isvalid untagged against registered tagged" -setup {
        set ptr [makeptr 1 TAG]
        cffi::pointer safe $ptr
    } -cleanup {
        cffi::pointer dispose $ptr
    } -body {
        cffi::pointer isvalid [makeptr 1]
    } -result 1

    test pointer-isvalid-7 "pointer isvalid null pointer" -body {
        cffi::pointer isvalid [makeptr 0]
    } -result 0

    test pointer-isvalid-8 "pointer isvalid null pointer" -body {
        cffi::pointer isvalid [makeptr 0 TAG]
    } -result 0

    ###
    # pointer list
    testnumargs pointer-list "pointer list" "" ?TAG?

    test pointer-list-0 "pointer list empty" -body {
        cffi::pointer list
    } -result [list ]

    test pointer-list-1 "pointer list" -setup {
        cffi::pointer safe 0x1^TAG
        cffi::pointer safe 0x2^
    } -body {
        list [lsort [cffi::pointer list]] [cffi::pointer dispose 0x1^TAG] [cffi::pointer dispose 0x2^] [cffi::pointer list]
    } -result [list [list [makeptr 1 TAG] [makeptr 2]] {} {} {}]

    test pointer-list-2 "pointer list for tag" -setup {
        cffi::pointer safe 0x1^TAG
        cffi::pointer safe 0x2^
        cffi::pointer safe 0x3^BAG
    } -cleanup {
        cffi::pointer dispose 0x1^TAG
        cffi::pointer dispose 0x2^
        cffi::pointer dispose 0x3^BAG
    } -body {
        cffi::pointer list TAG
    } -result [list [makeptr 1 TAG]]

    test pointer-list-3 "pointer list no matches" -setup {
        cffi::pointer safe 0x1^TAG
    } -cleanup {
        cffi::pointer dispose 0x1^TAG
    } -body {
        cffi::pointer list TAGX
    } -result [list ]

    test pointer-list-4 "pointer list for void" -setup {
        cffi::pointer safe 0x1^TAG
        cffi::pointer safe 0x2^
        cffi::pointer safe 0x3^BAG
    } -cleanup {
        cffi::pointer dispose 0x1^TAG
        cffi::pointer dispose 0x2^
        cffi::pointer dispose 0x3^BAG
    } -body {
        cffi::pointer list ""
    } -result [list [makeptr 2]]

    ###
    # pointer safe
    testnumargs pointer-safe "pointer safe" POINTER
    testbadargs safe
    testnullptr safe

    test pointer-safe-0 "pointer safe" -body {
        set p [makeptr 1]
        list [cffi::pointer safe $p] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result [list [makeptr 1] 1 {} 0]
    test pointer-safe-1 "pointer safe tagged" -body {
        set p [makeptr 1 TAG]
        list [cffi::pointer safe $p] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result [list [makeptr 1 TAG] 1 {} 0]
    test pointer-safe-2 "pointer safe dup ok" -body {
        set p [makeptr 1 TAG]
        cffi::pointer safe $p
        list [cffi::pointer isvalid $p] [catch {cffi::pointer safe $p}] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result {1 0 1 {} 0}
    test pointer-safe-error-0 "pointer safe after counted" -body {
        set p [makeptr 1 ::TAG]
        cffi::pointer counted $p
        list [cffi::pointer isvalid $p] [catch {cffi::pointer safe $p} result] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p] $result
    } -result [list 1 0 1 {} 0 [makeptr 1 ::TAG]]

    ###
    # pointer counted
    testnumargs pointer-counted "pointer counted" POINTER
    testbadargs counted
    testnullptr counted

    test pointer-counted-0 "pointer counted" -body {
        set p [makeptr 1]
        list \
            [cffi::pointer counted $p] \
            [cffi::pointer counted $p] \
            [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result [list [makeptr 1] [makeptr 1] 1 {} 1 {} 0]
    test pointer-counted-1 "pointer counted tag" -body {
        set p [makeptr 1 TAG]
        cffi::pointer counted $p
        cffi::pointer counted $p
        list [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result {1 {} 1 {} 0}
    test pointer-counted-error-0 "pointer counted after safe" -body {
        set p [makeptr 1 ::TAG]
        cffi::pointer safe $p
        list [cffi::pointer isvalid $p] [catch {cffi::pointer counted $p} result] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p] $result
    } -result [list 1 0 1 {} 0 [makeptr 1 ::TAG]]
    test pointer-counted-error-1 "pointer counted tag conflict" -body {
        set p [makeptr 1 ::TAG]
        set p2 [makeptr 1 ::TAG2]
        cffi::pointer counted $p
        list [catch {cffi::pointer counted $p2} result] [cffi::pointer dispose $p2] $result
    } -result [list 0 {} [makeptr 1 ::TAG2]]

    ###
    # pointer dispose
    testnumargs pointer-dispose "pointer dispose" POINTER
    testbadargs dispose
    test pointer-dispose-0 "pointer dispose" -body {
        set p [makeptr 1]
        cffi::pointer safe $p
        list [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result {1 {} 0}
    test pointer-dispose-1 "pointer dispose counted" -body {
        set p [makeptr 1]
        cffi::pointer counted $p
        cffi::pointer counted $p
        list [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p] [cffi::pointer dispose $p] [cffi::pointer isvalid $p]
    } -result {1 {} 1 {} 0}
    test pointer-dispose-null-0 "pointer dispose NULL pointer" -body {
        set p [makeptr 0]
        cffi::pointer dispose $p
    } -result {}
    test pointer-dispose-null-1 "pointer dispose NULL pointer TAG" -body {
        set p [makeptr 0 TAG]
        cffi::pointer dispose $p
    } -result {}

    ###
    # pointer isnull
    testnumargs pointer-isnull "pointer isnull" POINTER
    testbadargs isnull
    test pointer-isnull-0 "pointer isnull" -body {
        cffi::pointer isnull [makeptr 0]
    } -result 1
    test pointer-isnull-1 "pointer isnull tagged" -body {
        cffi::pointer isnull [makeptr 0 TAG]
    } -result 1
    test pointer-isnull-2 "pointer isnull nonnull" -body {
        cffi::pointer isnull [makeptr 1]
    } -result 0
    test pointer-isnull-3 "pointer isnull nonnull tagged" -body {
        cffi::pointer isnull [makeptr 1 TAG]
    } -result 0

    ###
    # pointer address
    testnumargs pointer-address "pointer address" POINTER
    testbadargs address
    test pointer-address-0 "pointer address" -body {
        cffi::pointer address [makeptr 1]
    } -result [format 0x%.[expr {2 * $::tcl_platform(pointerSize)}]lx 1]
    test pointer-address-1 "pointer address tagged" -body {
        cffi::pointer address [makeptr 1 TAG]
    } -result [format 0x%.[expr {2 * $::tcl_platform(pointerSize)}]lx 1]
    test pointer-address-2 "pointer address nullptr" -body {
        cffi::pointer address [makeptr 0]
    } -result [format 0x%.[expr {2 * $::tcl_platform(pointerSize)}]lx 0]
    test pointer-address-3 "pointer address nullptr tagged" -body {
        cffi::pointer address [makeptr 0 TAG]
    } -result [format 0x%.[expr {2 * $::tcl_platform(pointerSize)}]lx 0]

    ###
    # pointer make
    testnumargs pointer-make "pointer make" "ADDRESS" "?TAG?"
    test pointer-make-0 "make pointer without tag" -body {
        cffi::pointer make 1
    } -result [makeptr 1]
    test pointer-make-1 "make pointer with tag" -body {
        cffi::pointer make 1 TAG
    } -result [scoped_ptr 1 TAG]
    test pointer-make-2 "make NULL pointer - ignore tag" -body {
        cffi::pointer make 0 TAG
    } -result [makeptr 0]
    test pointer-make-3 "make pointer with fqn tag" -body {
        cffi::pointer make 1 ::TAG
    } -result [scoped_ptr 1 ::TAG]

    ###
    # pointer casting
    testnumargs pointer-cast "pointer cast" "POINTER" "?TAG?"
    test pointer-cast-0 "Cast an unsafe pointer to void*" -body {
        list [::cffi::pointer cast [cffi::pointer make 1 TAG]] [::cffi::pointer list]
    } -result [list [makeptr 1] {}]

    test pointer-cast-1 "Cast an safe pointer to void*" -setup {
        set p [cffi::pointer make 1 TAG]
        cffi::pointer safe $p
    } -cleanup {
        cffi::pointer dispose [cffi::pointer make 1]
    } -body {
        list [::cffi::pointer list] [cffi::pointer cast $p] [::cffi::pointer list]
    } -result [list [list [cffi::pointer make 1 TAG]] [cffi::pointer make 1] [list [cffi::pointer make 1]]]

    test pointer-cast-2 "Cast an unsafe pointer from void*" -body {
        list [::cffi::pointer cast [cffi::pointer make 1] TAG] [::cffi::pointer list]
    } -result [list [makeptr 1 [namespace current]::TAG] {}]

    test pointer-cast-3 "Cast an safe pointer from void*" -setup {
        set p [cffi::pointer make 1]
        cffi::pointer safe $p
    } -cleanup {
        cffi::pointer dispose [cffi::pointer make 1 TAG]
    } -body {
        list [::cffi::pointer list] [cffi::pointer cast $p TAG] [::cffi::pointer list]
    } -result [list [list [cffi::pointer make 1]] [cffi::pointer make 1 TAG] [list [cffi::pointer make 1 TAG]]]

    test pointer-cast-4 "Cast a unsafe pointer" -setup {
        set p [cffi::pointer make 1 ::T]
    } -cleanup {
        cffi::pointer uncastable ::T
    } -body {
        list $p [catch {cffi::pointer cast $p ::T2}] [cffi::pointer castable ::T ::T2] [cffi::pointer cast $p ::T2] [cffi::pointer list]
    } -result [list [makeptr 1 ::T] 1 {} [makeptr 1 ::T2] {}]

    test pointer-cast-5 "Cast unsafe pointers unqualified" -setup {
        set p [cffi::pointer make 1 T]
    } -cleanup {
        cffi::pointer uncastable T
    } -body {
        list $p \
            [catch {cffi::pointer cast $p T2}] \
            [cffi::pointer castable T T2] \
            [set p2 [cffi::pointer cast $p T2]] \
            [set p [cffi::pointer cast $p2 T]] \
            [cffi::pointer list]
    } -result [list [makeptr 1 [namespace current]::T] \
                   1 \
                   {} \
                   [makeptr 1 [namespace current]::T2] \
                   [makeptr 1 [namespace current]::T] \
                   {} \
                  ]
    test pointer-cast-6 "Cast safe pointers unqualified" -setup {
        set p [cffi::pointer make 1 T]
        cffi::pointer safe $p
    } -cleanup {
        cffi::pointer dispose $p
        cffi::pointer uncastable T
    } -body {
        list $p \
            [catch {cffi::pointer cast $p T2}] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer castable T T2] \
            [set p2 [cffi::pointer cast $p T2]] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer isvalid $p2] \
            [set p [cffi::pointer cast $p2 T]] \
            [cffi::pointer list]
    } -result [list [makeptr 1 [namespace current]::T] \
                   1 \
                   1 \
                   {} \
                   [makeptr 1 [namespace current]::T2] \
                   1 \
                   1 \
                   [makeptr 1 [namespace current]::T] \
                   [list [makeptr 1 [namespace current]::T]] \
                  ]

    # More exhaustive combinations. May overlap with some tests above
    proc testcast {taga tagb registeredTag result args} {
        set id pointer-cast-$taga-$tagb-$registeredTag
        set comment "pointer cast $taga->$tagb, $registeredTag"
        if {$taga eq "void"} {set taga ""}
        if {$tagb eq "void"} {set tagb ""}
        if {$registeredTag eq "void"} {set registeredTag ""}
        set setup {
            purge_pointers
            set pa [cffi::pointer make 1 $taga]
            if {$registeredTag ne "-"} {
                ::cffi::pointer safe [::cffi::pointer make 1 $registeredTag]
            }
        }
        set cleanup {
            unset -nocomplain pa
            purge_pointers
        }
        set filteredArgs {}
        set args [foreach {opt val} $args {
            if {$opt eq "-setup"} {
                append setup \n $val
                continue
            }
            if {$opt eq "-cleanup"} {
                append cleanup \n $val
                continue
            }
            lappend filteredArgs $opt $val
        }]
        test $id $comment -setup $setup -cleanup $cleanup -body {
            list [cffi::pointer cast $pa $tagb] [cffi::pointer list]
        } -result $result {*}$filteredArgs
    }
    # Unregistered casts
    testcast void void - [list [pointer1] [list ]]
    testcast void T    - [list [pointer1 T] [list ]]
    testcast T    T    - [list [pointer1 T] [list ]]
    testcast T    void - [list [pointer1] [list ]]
    testcast T    T2   - "Value has the wrong type. Expected pointer^::cffi::test::T2, got pointer^::cffi::test::T." -returnCodes error
    testcast T    BASE - [list [pointer1 BASE] [list ]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast BASE T - [list [pointer1 T] [list ]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    # Registered casts
    testcast void void void [list [pointer1] [list [pointer1]]]
    testcast void void T    [list [pointer1] [list [pointer1]]]
    testcast void T    void [list [pointer1 T] [list [pointer1 T]]]
    testcast void T    T    [list [pointer1 T] [list [pointer1 T]]]
    testcast T    void void [list [pointer1] [list [pointer1]]]
    testcast T    void T    [list [pointer1] [list [pointer1]]]
    testcast T    T    void [list [pointer1 T] [list [pointer1 T]]]
    testcast T    T    T    [list [pointer1 T] [list [pointer1 T]]]
    testcast T    T2   T    "Value has the wrong type. Expected pointer^::cffi::test::T2, got pointer^::cffi::test::T." -returnCodes error
    testcast T    T2   T2   "Value has the wrong type. Expected pointer^::cffi::test::T2, got pointer^::cffi::test::T." -returnCodes error
    testcast T    BASE void [list [pointer1 BASE] [list [pointer1 BASE]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast T    BASE T [list [pointer1 BASE] [list [pointer1 BASE]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast T    BASE BASE [list [pointer1 BASE] [list [pointer1 BASE]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast T    BASE T2 "Value has the wrong type. Expected pointer^::cffi::test::T2, got pointer^::cffi::test::T." -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    } -returnCodes error

    testcast BASE    T void [list [pointer1 T] [list [pointer1 T]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast BASE    T T [list [pointer1 T] [list [pointer1 T]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast BASE    T BASE [list [pointer1 T] [list [pointer1 T]]] -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    }
    testcast BASE    T T2 "Value has the wrong type. Expected pointer^::cffi::test::T2, got pointer^::cffi::test::BASE." -setup {
        cffi::pointer castable T BASE
    } -cleanup {
        cffi::pointer uncastable T
    } -returnCodes error

    ###
    # castable tests
    testnumargs pointer-castable "pointer castable" "SUBTAG SUPERTAG" ""
    test pointer-castable-0 "Pointer argument castable" -setup {
        testDll function {pointer_to_pointer upcast} {pointer unsafe} {p {pointer.T unsafe}}
        testDll function {pointer_to_pointer downcast} {pointer unsafe} {p {pointer.T2 unsafe}}
    } -cleanup {
        cffi::pointer uncastable T2
    } -body {
        set t [cffi::pointer make 1 T]
        set t2 [cffi::pointer make 1 T2]
        list \
            [upcast $t] \
            [catch {upcast $t2}] \
            [catch {downcast $t}] \
            [cffi::pointer castable T2 T] \
            [cffi::pointer castables] \
            [upcast $t2] \
            [catch {downcast $t}] \
            [cffi::pointer uncastable T2] \
            [cffi::pointer castables]
    } -result [list [makeptr 1] 1 1 {} {::cffi::test::T2 ::cffi::test::T} [makeptr 1] 1 {} {}]

    test pointer-castable-1 "Pointer argument castable - void*" -setup {
        testDll function {pointer_to_pointer upcast} {pointer unsafe} {p {pointer unsafe}}
        testDll function {pointer_to_pointer downcast} {pointer unsafe} {p {pointer.T2 unsafe}}
    } -cleanup {
        cffi::pointer uncastable T2
    } -body {
        set t [cffi::pointer make 1]
        set t2 [cffi::pointer make 1 T2]
        list \
            [upcast $t] \
            [upcast $t2] \
            [catch {downcast $t}]
    } -result [list [makeptr 1] [makeptr 1] 1]

    test pointer-castable-2 "Pointer field castable" -setup {
        cffi::Struct create S {p {pointer.::T unsafe}}
    } -cleanup {
        S free $s
        S free $s2
        cffi::pointer uncastable ::T2
    } -body {
        list \
            [catch {S new [list p [makeptr 1 ::T]]} s] \
            [catch {S new [makeptr 1 ::T2]}] \
            [cffi::pointer castable ::T2 ::T] \
            [catch {S new [list p [makeptr 1 ::T2]]} s2] \
        } -result [list 0 1 {} 0]

    test pointer-castable-3 "Pointer field castable to void*" -setup {
        cffi::Struct create S {p {pointer unsafe}}
    } -cleanup {
        S free $s
    } -body {
            catch {S new [list p [makeptr 1 ::T]]} s
    } -result 0

    test pointer-castable-4 "Pointer field castable from void*" -setup {
        cffi::Struct create S {p {pointer.::T unsafe}}
    } -body {
        S new [list p [makeptr 1]]
    } -result "Value*has the wrong type. Expected pointer to ::T. Error converting field ::cffi::test::S.p to a native value." -match glob -returnCodes error

    test pointer-castable-5 "Pointer argument multiple castable" -setup {
        testDll function {pointer_to_pointer upcast} {pointer unsafe} {p {pointer.T unsafe}}
    } -cleanup {
        cffi::pointer uncastable T2
        cffi::pointer uncastable ::T3
    } -body {
        set t [cffi::pointer make 1 T]
        set t2 [cffi::pointer make 2 T2]
        set t3 [cffi::pointer make 3 ::T3]
        list \
            [cffi::pointer castable {T2 ::T3} T] \
            [cffi::pointer castables] \
            [upcast $t2] \
            [upcast $t3]
    } -result [list {} {::cffi::test::T2 ::cffi::test::T ::T3 ::cffi::test::T} [makeptr 2] [makeptr 3]]

    ###
    # pointer compare
    testnumargs pointer-compare "pointer compare" "POINTER POINTER" ""
    test pointer-compare-0 "Compare equal - no tags" -body {
        cffi::pointer compare [makeptr 1] [makeptr 1]
    } -result 1
    test pointer-compare-1 "Compare equal - tags" -body {
        cffi::pointer compare [makeptr 1 TAG] [makeptr 1 TAG]
    } -result 1
    test pointer-compare-2 "Compare equal addresses" -body {
        cffi::pointer compare [makeptr 1 TAG] [makeptr 1 TAG2]
    } -result -1
    test pointer-compare-3 "Compare equal addresses" -body {
        cffi::pointer compare [makeptr 1] [makeptr 1 TAG]
    } -result -1
    test pointer-compare-4 "Compare unequal addresses" -body {
        cffi::pointer compare [makeptr 1] [makeptr 2]
    } -result 0
    test pointer-compare-5 "Compare unequal addresses - same tag" -body {
        cffi::pointer compare [makeptr 1 TAG] [makeptr 2 TAG]
    } -result 0
    test pointer-compare-6 "Compare NULL" -body {
        cffi::pointer compare NULL NULL
    } -result 1
    test pointer-compare-7 "Compare NULL with non-NULL" -body {
        cffi::pointer compare [makeptr 1] NULL
    } -result 0

    ###
    # Ensure empty tag treated as void pointer
    test pointer-empty-tag-0 "pointer make empty tag" -body {
        cffi::pointer make 1 ""
    } -result [cffi::pointer make 1]
    test pointer-empty-tag-1 "pointer cast empty tag" -body {
        cffi::pointer cast [cffi::pointer make 1 T] ""
    } -result [cffi::pointer make 1]

    ###
    # pointer pin
    testnumargs pointer-pin "pointer pin" "POINTER"
    testnullptr pin
    testbadargs pin
    test pointer-pinned-0 "Pin pointer" -body {
        set p [pointer1]
        list [cffi::pointer pin $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer safe $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer counted $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer invalidate $p] \
            [cffi::pointer isvalid $p]
    } -result [list [pointer1] 1 {} 1 [pointer1] {} 1 [pointer1] {} 1 {} 0]

    test pointer-pinned-1 "Pin pointer with tag" -body {
        set p [pointer1 T]
        list [cffi::pointer pin $p] \
            [cffi::pointer list] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer safe $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer counted $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer invalidate $p] \
            [cffi::pointer isvalid $p]
    } -result [list [pointer1 T] [pointer1] 1 {} 1 [pointer1 T] {} 1 [pointer1 T] {} 1 {} 0]

    test pointer-pinned-2 "Pin safe pointer" -body {
        set p [pointer1]
        cffi::pointer safe $p
        list [cffi::pointer pin $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer safe $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer counted $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer invalidate $p] \
            [cffi::pointer isvalid $p]
    } -result [list [pointer1] 1 {} 1 [pointer1] {} 1 [pointer1] {} 1 {} 0]

    test pointer-pinned-3 "Pin counted pointer" -body {
        set p [pointer1]
        cffi::pointer counted $p
        list [cffi::pointer pin $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer safe $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer counted $p] \
            [cffi::pointer dispose $p] \
            [cffi::pointer isvalid $p] \
            [cffi::pointer invalidate $p] \
            [cffi::pointer isvalid $p]
    } -result [list [pointer1] 1 {} 1 [pointer1] {} 1 [pointer1] {} 1 {} 0]

    test pointer-pinned-4 "Cast should not change tag of pinned pointer" -body {
        set p [pointer1]
        list [cffi::pointer pin $p] \
            [cffi::pointer list] \
            [cffi::pointer cast $p T] \
            [cffi::pointer list] \
            [cffi::pointer invalidate $p] \
            [cffi::pointer list]
    } -result [list [pointer1] [pointer1] [pointer1 T] [pointer1] {} {}]

    ###
    # pointer invalidate
    testnumargs pointer-invalidate "pointer invalidate" POINTER
    testbadargs invalidate
    test pointer-invalidate-0 "pointer invalidate safe" -body {
        set p [makeptr 1]
        cffi::pointer safe $p
        list [cffi::pointer isvalid $p] [cffi::pointer invalidate $p] [cffi::pointer isvalid $p]
    } -result {1 {} 0}
    test pointer-invalidate-1 "pointer invalidate counted" -body {
        set p [makeptr 1]
        cffi::pointer counted $p
        cffi::pointer counted $p
        list [cffi::pointer isvalid $p] [cffi::pointer invalidate $p] [cffi::pointer isvalid $p] [cffi::pointer invalidate $p] [cffi::pointer isvalid $p]
    } -result {1 {} 0 {} 0}
    test pointer-invalidate-2 "pointer invalidate NULL pointer" -body {
        set p [makeptr 0]
        cffi::pointer invalidate $p
    } -result {}
    test pointer-invalidate-3 "pointer invalidate NULL pointer TAG" -body {
        set p [makeptr 0 TAG]
        cffi::pointer invalidate $p
    } -result {}
    test pointer-invalidate-4 "pointer invalidate unsafe - no error raised" -body {
        set p [makeptr 1]
        list [cffi::pointer isvalid $p] [cffi::pointer invalidate $p]
    } -result {0 {}}
    test pointer-invalidate-5 "pointer invalidate pinned" -body {
        set p [makeptr 1]
        cffi::pointer pin $p
        list [cffi::pointer isvalid $p] [cffi::pointer invalidate $p] [cffi::pointer isvalid $p]
    } -result {1 {} 0}

    ###
    # pointer info
    # Only unregistered pointers. Registered pointers info tested
    # as part of re-registering test set

    test pointer-info-unregistered-0 {unregistered pointer info} -body {
        cffi::pointer info [pointer1]
    } -result {Tag {} Registration none}

    test pointer-info-unregistered-1 {unregistered pointer info tagged} -body {
        cffi::pointer info [pointer1 ::T]
    } -result {Tag ::T Registration none}

    ###
    # Tests for pointer re-registering.

    proc testregistration {id comment oldptr newptr oldreg newreg result args} {
        set setup {
            purge_pointers
            pointer $oldreg $oldptr
        }
        set cleanup {
            unset -nocomplain pa
            purge_pointers
        }
        set filteredArgs {}
        set args [foreach {opt val} $args {
            if {$val eq {}} continue
            if {$opt eq "-setup"} {
                append setup \n $val
                continue
            }
            if {$opt eq "-cleanup"} {
                append cleanup \n $val
                continue
            }
            lappend filteredArgs $opt $val
        }]
        test pointer-register-$oldreg-$newreg-$id $comment -body {
            cffi::pointer $newreg $newptr
            cffi::pointer info $newptr
        } -setup $setup -cleanup $cleanup -result $result -match dict {*}$filteredArgs
    }
    testregistration untagged "unregistered -> safe" [pointer1] [pointer1] invalidate safe {
        Tag {} Registration safe Match exact RegisteredTag {}
    }
    testregistration tagged "unregistered -> safe" [pointer1 ::T] [pointer1 ::T] invalidate safe {
        Tag ::T Registration safe Match exact RegisteredTag ::T
    }
    testregistration untagged "unregistered -> counted" [pointer1] [pointer1] invalidate counted {
        Tag {} Registration counted Match exact RegisteredTag {}
    }
    testregistration tagged "unregistered -> counted" [pointer1 ::T] [pointer1 ::T] invalidate counted {
        Tag ::T Registration counted Match exact RegisteredTag ::T
    }
    testregistration untagged "unregistered -> pinned" [pointer1] [pointer1] invalidate pin {
        Tag {} Registration pinned Match exact RegisteredTag {}
    }
    testregistration tagged "unregistered -> pinned" [pointer1 ::T] [pointer1 ::T] invalidate pin {
        Tag ::T Registration pinned Match derived RegisteredTag {}
    }

    # {safe,counted,pinned}->safe,counted,pinned
    # notag->notag
    # notag->tag
    # tag->notag
    # tag->tag
    # tag->tag2
    # inherited tags
    foreach {oldreg newreg oldtag newtag result setup cleanup} {
        #*->    safe *    *    *  * *

        safe    safe ""   ""  {Tag {} Registration safe Match exact RegisteredTag {}} {} {}
        counted safe ""   ""  {Tag {} Registration safe Match exact RegisteredTag {}} {} {}
        pin     safe ""   ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    safe ""   ::T {Tag ::T Registration safe Match derived RegisteredTag {}} {} {}
        counted safe ""   ::T {Tag ::T Registration safe Match exact RegisteredTag ::T} {} {}
        pin     safe ""   ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    safe ::T  ""  {Tag {} Registration safe Match exact RegisteredTag {}} {} {}
        counted safe ::T  ""  {Tag {} Registration safe Match exact RegisteredTag {}} {} {}
        pin     safe ::T  ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    safe ::T  ::T {Tag ::T Registration safe Match exact RegisteredTag ::T} {} {}
        counted safe ::T  ::T {Tag ::T Registration safe Match exact RegisteredTag ::T} {} {}
        pin     safe ::T  ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    safe ::T  ::T2 {Tag ::T2 Registration safe Match exact RegisteredTag ::T2} {} {}
        counted safe ::T  ::T2 {Tag ::T2 Registration safe Match exact RegisteredTag ::T2} {} {}
        pin     safe ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {} {}

        safe    safe ::T  ::T2 {Tag ::T2 Registration safe Match derived RegisteredTag ::T} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        counted safe ::T  ::T2 {Tag ::T2 Registration safe Match exact RegisteredTag ::T2} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        pin     safe ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}

        #*->    counted *    *    * * *

        safe    counted ""   ""  {Tag {} Registration counted Match exact RegisteredTag {}} {} {}
        counted counted ""   ""  {Tag {} Registration counted Match exact RegisteredTag {}} {} {}
        pin     counted ""   ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    counted ""   ::T {Tag ::T Registration counted Match exact RegisteredTag ::T} {} {}
        counted counted ""   ::T {Tag ::T Registration counted Match derived RegisteredTag {}} {} {}
        pin     counted ""   ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    counted ::T  ""  {Tag {} Registration counted Match exact RegisteredTag {}} {} {}
        counted counted ::T  ""  {Tag {} Registration counted Match exact RegisteredTag {}} {} {}
        pin     counted ::T  ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    counted ::T  ::T {Tag ::T Registration counted Match exact RegisteredTag ::T} {} {}
        counted counted ::T  ::T {Tag ::T Registration counted Match exact RegisteredTag ::T} {} {}
        pin     counted ::T  ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    counted ::T  ::T2 {Tag ::T2 Registration counted Match exact RegisteredTag ::T2} {} {}
        counted counted ::T  ::T2 {Tag ::T2 Registration counted Match exact RegisteredTag ::T2} {} {}
        pin     counted ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {} {}

        safe    counted ::T  ::T2 {Tag ::T2 Registration counted Match exact RegisteredTag ::T2} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        counted counted ::T  ::T2 {Tag ::T2 Registration counted Match derived RegisteredTag ::T} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        pin     counted ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}

        #*->    pin *    *    * * *

        safe    pin ""   ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}
        counted pin ""   ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}
        pin     pin ""   ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    pin ""   ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}
        counted pin ""   ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}
        pin     pin ""   ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    pin ::T  ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}
        counted pin ::T  ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}
        pin     pin ::T  ""  {Tag {} Registration pinned Match exact RegisteredTag {}} {} {}

        safe    pin ::T  ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}
        counted pin ::T  ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}
        pin     pin ::T  ::T {Tag ::T Registration pinned Match derived RegisteredTag {}} {} {}

        safe    pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {} {}
        counted pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {} {}
        pin     pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {} {}

        safe    pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        counted pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
        pin     pin ::T  ::T2 {Tag ::T2 Registration pinned Match derived RegisteredTag {}} {cffi::pointer castable ::T2 ::T} {cffi::pointer uncastable ::T2}
    } {
        if {[string index $oldreg 0] eq "#"} {
            continue
        }
        testregistration $oldtag-$newtag "$oldreg $oldtag -> $newreg $newtag" [pointer1 $oldtag] [pointer1 $newtag] $oldreg $newreg $result -setup $setup -cleanup $cleanup
    }
}

::tcltest::cleanupTests
namespace delete ${NS}::test
