# C - generate C code from inter-textual representation in Tcl
#
# slavishly derived and simplified from the excellent critcl
# Colin McCormack, Steve Landers, Jean-Claude Wippler other parties

package require Tcl 8.5
package require TclOO
package provide C 1.0

if {![llength [info commands ::oo::Helpers::classvar]]} {
    proc ::oo::Helpers::classvar {name args} {
        # Get reference to class’s namespace
        set ns [info object namespace [uplevel 1 {self class}]]
        
        # Double up the list of varnames
        set vs [list $name $name]
        foreach v $args {lappend vs $v $v}
        
        # Link the caller’s locals to the
        # class’s variables
        tailcall namespace upvar $ns {*}$vs
    }
}

namespace eval ::C {}

# HC class for common functionality
oo::class create ::C::HC {
    variable ns nsObj name a

    # set of all namespace objects
    method namespaces {} {
        classvar namespaces
        return $namespaces
    }

    # namespace objects pertaining to self
    method objects {} {
        return [$nsObj objects]
    }

    method namespace {} {
        return $nsObj
    }

    # command to generate Tcl command
    method gencmd {} {
        return ""
    }

    method fqname {} {
        return \"${ns}::$name\"
    }

    method cname {} {
        return [string map {:: _} $ns]$name
    }

    destructor {
        # destroy all the components of the namespace
        foreach {n member} $members {
            foreach v $member {
                $v destroy
            }
        }
    }

    constructor {_ns {_name ""} args} {
        set ns $_ns
        set name $_name
        set a $args
        if {$ns == "::"} { set ns "" } else { append ns :: }

        # register self to this namespace
        classvar namespaces
        if {![info exists namespaces]} {
            set namespaces {}
        }

        if {![dict exists $namespaces $ns]} {
            set nsObj [::C::Cns new $ns]
            dict set namespaces $ns $nsObj
        } else {
            set nsObj [dict get $namespaces $ns]
        }

        $nsObj add $name [self]

        set cns [string map {:: _} $ns]

        set file [file normalize [info script]]
        if {0} {
            set ::auto_index($ns$name) [list [namespace current]::cbuild $file]
            variable code; variable curr; variable options
            lappend code($file,list) $cns$name $curr
            if {$options(lines)} {
                append code($curr) "#line 1" \"[file tail $file]/$name\" \n
            }
        }
    }

}

# Cproc - express C functions in Tcl proc wrapper
oo::class create ::C::Cproc {
    superclass ::C::HC
    variable code name adefs rtype body

    # command to generate Tcl command
    method gencmd {} {
        variable clientdata
        variable delproc
        return "Tcl_CreateObjCommand(ip, [my fqname], tcl_[my cname], NULL, 0);\n"
    }

    method generate {} {
        return $code
    }

    constructor {_name _adefs _rtype {_body "#"}} {
        foreach n {name adefs rtype body} {
            set $n [set _$n]
        }

        set ns [uplevel 1 namespace current]
        variable name $_name
        next $ns $name $adefs $rtype $body

        array set types {}
        set names {}
        set cargs {}
        set cnames {}

        # is first arg is "Tcl_Interp*", pass it without counting it as a cmd arg
        if {[lindex $adefs 0] == "Tcl_Interp*"} {
            lappend cnames ip
            lappend cargs [lrange $adefs 0 1]
            set adefs [lrange $adefs 2 end]
        }

        # generate the function arg signature
        foreach {t n} $adefs {
            lappend names $n
            lappend cnames _$n
            if {$t eq "bytearray" || $t eq "rawchar*"} {
                lappend cargs "char *$n"
            } else {
                lappend cargs "$t $n"
            }
        }

        # determine the function return type
        switch -- $rtype {
            ok      { set rtype2 "int" }
            string -
            dstring -
            vstring { set rtype2 "char*" }
            default { set rtype2 $rtype }
        }

        # generate the c function to be wrapped
        if {$body != "#"} {
            set code [subst {
                static $rtype2 c_[my cname] ([join $cargs {, }]) {
                    $body
                }
            }]
        } else {
            set code [subst {
                #define c_[my cname] [my name]
            }]
        }

        # generate the wrapper header
            append code [subst {
            static int tcl_[my cname] (ClientData cd, Tcl_Interp *ip, int oc, Tcl_Obj *CONST ov\[\]) \{
        }]
        
        # generate the wrapper arg declarations
        foreach {t n} $adefs {
            switch -- $t {
                int - long - float - double -
                char* - int* - float* - double* -
                Tcl_Obj* {
                    append code "$t _$n;" \n
                }
                bytearray -
                rawchar* {
                    append code "char* _$n;" \n
                }
                default {
                    append code "void *_$n;" \n
                }
            }
        }
        
        # generate the functional return type
        if {$rtype != "void"} {
            append code "$rtype2 rv;" \n
        }

        # check the args passed in from Tcl
        append code [subst {
            if (oc != [expr {[llength $names] + 1}]) {
                Tcl_WrongNumArgs(ip, 1, ov, "[join $names { }]");
                return TCL_ERROR;
            }
        }]

        # generate the Tcl arg conversion
        set i 0
        foreach {t n} $adefs {
            set ov "ov\[[incr i]\]"
            switch -- $t {
                int {
                    append code [subst {
                        if (Tcl_GetIntFromObj(ip, $ov, &_$n) != TCL_OK)
                        return TCL_ERROR;
                    }]
                }

                long {
                    append code [subst {
                        if (Tcl_GetLongFromObj(ip, $ov, &_$n) != TCL_OK)
                        return TCL_ERROR;
                    }]
                }

                float {
                    append code [subst {{
                        double t;
                        if (Tcl_GetDoubleFromObj(ip, $ov, &t) != TCL_OK)
                        return TCL_ERROR;
                        _$n = (float) t;
                    }}]
                }

                double {
                    append code [subst {
                        if (Tcl_GetDoubleFromObj(ip, $ov, &_$n) != TCL_OK)
                        return TCL_ERROR;
                    }]
                }
                
                char* {
                    append code [subst {
                        _$n = Tcl_GetString($ov);
                    }]
                }
                
                int* -
                float* -
                double* {
                    append code [subst {
                        _$n = ($t) Tcl_GetByteArrayFromObj($ov, NULL);
                        Tcl_InvalidateStringRep($ov);
                    }]
                }
                
                bytearray -
                rawchar* {
                    append code [subst {
                        _$n = (char*) Tcl_GetByteArrayFromObj($ov, NULL);
                        Tcl_InvalidateStringRep($ov);
                    }]
                }
                
                default {
                    append code [subst {
                        _$n = $ov;
                    }]
                }
            }
        }
        
        # generate wrapper code to invoke wrapped function
        if {$rtype ne "void"} {
            set rv [subst {c_[my cname]([join $cnames {, }])}]
        }
        
        # generate wrapper return value code
        switch -- $rtype {
            void {
                append code $rv;
            }
            ok {
                append code [subst {
                    return $rv;
                }]
            }
            int        {
                append code [subst {
                    Tcl_SetObjResult(ip, Tcl_NewIntObj($rv));
                }]
            }
            long {
                append code [subst {
                    Tcl_SetObjResult(ip, Tcl_NewLongObj($rv));
                }]
            }
            float -
            double        {
                append code [subst {
                    Tcl_SetObjResult(ip, Tcl_NewDoubleObj($rv));
                }]
            }
            char* {
                append code [subst {
                    Tcl_SetResult(ip, $rv, TCL_STATIC);
                }]
            }
            string -
            dstring {
                append code [subst {
                    Tcl_SetResult(ip, $rv, TCL_DYNAMIC);
                }]
            }
            vstring {
                append code [subst{
                    Tcl_SetResult(ip, $rv, TCL_VOLATILE);
                }]
            }
            default {
                append code [subst {
                    rv = $rv;
                    Tcl_SetObjResult(ip, rv);
                    Tcl_DecrRefCount(rv);
                }]
            }
        }

        # generate the wrapper return itself
        if {$rtype != "ok"} {
            append code {
                return TCL_OK;
            }
        }
        append code \} \n
    }
}


# Ccommand - express C functions in Tcl command wrapper
oo::class create ::C::Ccommand {
    superclass ::C::HC
    variable code name anames body

    # command to generate Tcl command
    method gencmd {} {
        variable clientdata
        variable delproc
        return "Tcl_CreateObjCommand(ip, [my fqname], tcl_[my cname], $clientdata, $delproc);\n"
    }

    method generate {} {
        return $code
    }

    constructor {_name _anames args} {
        set name $_name
        set anames $_anames
        if {[llength $args]%2} {
            set body [lindex $args end]
            set args [lrange $args 0 end-1]
        } else {
            set body ""
        }

        variable clientdata NULL
        variable delproc 0
        set namespace [uplevel 1 namespace current]
        dict for {n v} $args {
            set [string trim $n -] $v
        }
        my clientdata $clientdata
        my delproc $delproc

        next $namespace $name $anames $body
        set code "#define ns_[my cname] \"$ns$name\" \n"

        if {$body != ""} {
            # set wrapper arg defaults
            set cd clientdata
            set ip interp
            set oc objc
            set ov objv

            lassign $anames cd ip oc ov        ;# get wrapper args from cproc args

            # generate wrapper
            set code [subst {
                static int tcl_[my cname] (ClientData $cd, Tcl_Interp *$ip, int $oc, Tcl_Obj *CONST $ov\[\]) {
                    $body
                }
            }]

        } else {
            # if no body is specified, then $anames is alias for the real cmd proc
            set code [subst {
                #define tcl_[my cname] $anames
                int $anames\(\);
            }]
        }
    }
}

# Ccommand - express C data in Tcl wrapper
oo::class create ::C::Cdata {
    superclass ::C::Ccommand

    constructor {name data} {
        binary scan $data c* bytes ;# split as bytes, not (unicode) chars

        set inittext ""
        set line ""
        foreach x $bytes {
            if {[string length $line] > 70} {
                append inittext "    " $line \n
                set line ""
            }
            append line $x ,
        }
        append inittext "    " $line

        set count [llength $bytes]
        
        next $name {dummy ip objc objv} -namespace [uplevel 1 namespace current] [subst {
            static char script\[$count\] = {
                $inittext
            };
            Tcl_SetByteArrayObj(Tcl_GetObjResult(ip), (unsigned char*) script, $count);
            return TCL_OK;
        }]
    }
}

# Ccommand - express C code in Tcl wrapper
oo::class create ::C::Ccode {
    superclass ::C::HC
    variable code
    method generate {} {
        return $code
    }
    constructor {text} {
        classvar unique
        set code $text
        next [uplevel 1 namespace current] [incr unique]
    }
}

# Cinit - express C code in Tcl wrapper
oo::class create ::C::Cinit {
    superclass ::C::HC
    variable code
    method generate {} {
        return $code
    }
    constructor {text} {
        classvar unique
        set code $text
        next [uplevel 1 namespace current] @init
    }
}

# Cext - express C code in Tcl wrapper
oo::class create ::C::Cprolog {
    superclass ::C::HC
    variable code
    method generate {} {
        return $code
    }
    constructor {text {name @prolog}} {
        set code $text
        next [uplevel 1 namespace current] $name
    }
}

# Namespace collector
oo::class create ::C::Cns {
    variable members ns
    constructor {_ns {_pkg ""}} {
        set ns $_ns
        if {$_pkg ne ""} {
            variable pkg
        } elseif {$ns ni {"" "::"}} {
            variable pkg $ns
        }
        set members {@init "" @prolog ""}        ;# the first member must be the init
        variable tk 0
    }
    
    method add {obj args} {
        dict lappend members $obj $args
    }

    method name {} {
        return $ns
    }

    method objects {} {
        return $members
    }

    method package {{p ""}} {
        variable pkg
        if {$p ne ""} {
            set pkg $p
        }
        if {![info exists pkg] || $pkg eq ""} {
            set pkg [string totitle $ns]
        }
        return $pkg
    }

    method generate {args} {
        variable pkg
        if {![info exists pkg] || $pkg eq ""} {
            error "C code must be in a namespace or have a package ([dict keys $members])"
        }

        variable {*}$args
        foreach var {prolog init} {
            set $var ""
            foreach member [dict get $members @$var] {
                append $var [$member generate]
            }
        }

        set code [subst {
            /* Generated by critcl on [clock format [clock seconds]]
            */
            #include <[::tcl::pkgconfig get includedir,runtime]/tcl.h>
        }]
        variable tk
        if {$tk} {
            append code [subst {
                #include <[::tcl::pkgconfig get includedir,runtime]/tk.h>
            }]
        }

        append code $prolog \n

        append xcode {
            #if USE_TCL_STUBS
            extern const TclStubs *tclStubsPtr;
            TclPlatStubs *tclPlatStubsPtr;
            struct TclIntStubs *tclIntStubsPtr;
            struct TclIntPlatStubs *tclIntPlatStubsPtr;

            static int MyInitTclStubs (Tcl_Interp *ip)
            {
                typedef struct {
                    char *result;
                    Tcl_FreeProc *freeProc;
                    int errorLine;
                    TclStubs *stubTable;
                } HeadOfInterp;
                
                HeadOfInterp *hoi = (HeadOfInterp*) ip;

                if (hoi->stubTable == NULL || hoi->stubTable->magic != TCL_STUB_MAGIC) {
                    ip->result = "This extension requires stubs-support.";
                    ip->freeProc = TCL_STATIC;
                    return 0;
                }

                tclStubsPtr = hoi->stubTable;

                if (Tcl_PkgRequire(ip, "Tcl", "8.1", 0) == NULL) {
                    tclStubsPtr = NULL;
                    return 0;
                }
                
                if (tclStubsPtr->hooks != NULL) {
                    tclPlatStubsPtr = tclStubsPtr->hooks->tclPlatStubs;
                    tclIntStubsPtr = tclStubsPtr->hooks->tclIntStubs;
                    tclIntPlatStubsPtr = tclStubsPtr->hooks->tclIntPlatStubs;
                }
                
                return 1;
            }
            #endif
        }

        if {$tk} {
            append xcode {
                #if USE_TK_STUBS
                
                TkStubs *tkStubsPtr;
                struct TkPlatStubs *tkPlatStubsPtr;
                struct TkIntStubs *tkIntStubsPtr;
                struct TkIntPlatStubs *tkIntPlatStubsPtr;
                struct TkIntXlibStubs *tkIntXlibStubsPtr;
                
                static int
                MyInitTkStubs (Tcl_Interp *ip)
                {
                    if (Tcl_PkgRequireEx(ip, "Tk", "8.1", 0, (ClientData*) &tkStubsPtr) == NULL)      return 0;
                    if (tkStubsPtr == NULL || tkStubsPtr->hooks == NULL) {
                        Tcl_SetResult(ip, "This extension requires Tk stubs-support.", TCL_STATIC);
                        return 0;
                    }
                    tkPlatStubsPtr = tkStubsPtr->hooks->tkPlatStubs;
                    tkIntStubsPtr = tkStubsPtr->hooks->tkIntStubs;
                    tkIntPlatStubsPtr = tkStubsPtr->hooks->tkIntPlatStubs;
                    tkIntXlibStubsPtr = tkStubsPtr->hooks->tkIntXlibStubs;
                    return 1;
                }
                #endif
            }
        }

        dict for {n member} $members {
            if {[string match @* $n]} continue
            foreach v $member {
                append code [$v generate]
                append init [$v gencmd]
            }
        }

        append code [subst {
            #ifdef __cplusplus
            extern "C" {
                #endif
                DLLEXPORT int
                [string totitle $pkg]_Init(Tcl_Interp *ip)
                {
                    #if USE_TCL_STUBS
                    if (!Tcl_InitStubs(ip, TCL_VERSION, 0)) return TCL_ERROR;
                    //if (!MyInitTclStubs(ip)) return TCL_ERROR;
                    #endif
                    #if USE_TK_STUBS
                    if (!Tk_InitStubs(ip, TK_VERSION, 0)) return TCL_ERROR;
                    //if (!MyInitTkStubs(ip)) return TCL_ERROR;
                    #endif
                    $init
                    return TCL_OK;
                }
                #ifdef __cplusplus
            }
            #endif
        }]
        return $code
    }
}

# C - wrap C code in Tcl, and generate Tcl shim
namespace eval ::C {

    ::proc proc {args} {
        uplevel 1 ::C::Cproc new $args
    }
    ::proc command {args} {
        uplevel 1 ::C::Ccommand new $args
    }
    ::proc data {args} {
        uplevel 1 ::C::Cdata new $args
    }
    ::proc init {args} {
        uplevel 1 ::C::Cinit new $args
    }
    ::proc code {args} {
        uplevel 1 ::C::Ccode new $args
    }
    ::proc prolog {args} {
        uplevel 1 ::C::Cprolog new $args
    }
    ::proc include {args} {
        foreach h $args {
            uplevel 1 ::C::Cprolog new "#include \"$h\""
        }
    }

    ::proc namespaces {} {
        return [[lindex [list {*}[info class instances ::C::Cproc] {*}[info class instances ::C::Ccommand]] 0] namespaces]
    }

    ::proc namespace {args} {
        if {![llength $args]} {
            set ns [uplevel 1 namespace current]
        } else {
            lassign $args ns
        }
        if {$ns == "::"} { set ns "" } else { append ns :: }
        tailcall dict get [namespaces] $ns
    }

    ::proc package {name} {
        set ns [uplevel 1 C namespace]
        tailcall $ns package $name
    }

    ::namespace export -clear *
    ::namespace ensemble create -subcommands {}
}

if {[info exists argv0] && ($argv0 eq [info script])} {
    # example
    C proc add {int x int y} int {
        return x + y;
    }

    C proc cube {int x} int {
        return x * x * x;
    }

    C package Junk

    puts [[C namespace] generate]
}