C.tcl

C.tcl is a simplified modularized reduced variant of critcl written with an aim to make critcl more accessible and more able to be worked on.

This code provides a namespace ensemble called C, which provides the cproc, ccommand, cdata, cinit and other commands which work much as critcl's do.

It depends upon CC.tcl to turn the generated C into a loadable extension. It uses 8.5 facilities (dict.) Lars H: More noticeably this appears to use 8.6 facilities (TclOO)! Or was the statement that CC.tcl uses 8.5 facilities? BTW, an outline of the interface between these two components would be illuminating.

AK: Lars, In Tcl 8.5 TclOO is a require'able package, so this can be said to be 8.5+. Added the necessary 'package require commands. Lars H: But why specifically mention dict (which similarly exists as a Tcl 8.4 require'able package), if that's not what defines the compatibility level?


jbr - Is there any reason why this code is trivially incompatible with critcl? Why isn't it a drop in replacement?

CMcC I wanted it to be a new start, that's why. I think c proc looks better than cproc. You can use interp alias if you like. I should add that I love critcl's concepts so much I want to open it up as a field of enquiry so people can have a good geek at it, make it better, and adopt it as their own. I hope C.tcl will become a component in something bigger and more wonderful, and so I'm re-factoring critcl with that in mind, not merely to make a critcl-alike.


# 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]
}