Refactor c.tcl to create a sealed namespace

so you can build multiple C modules without weird intermingling

2 files changed, 168 insertions, 151 deletions

diff --git a/lib/c.tcl b/lib/c.tcl
index 2be77213..d503b700 100644
--- a/lib/c.tcl
+++ b/lib/c.tcl
@@ -1,154 +1,170 @@
 namespace eval c {
-    variable prelude {
-        #include <tcl.h>
-        #include <inttypes.h>
-        #include <stdint.h>
-    }
-    variable code [list]
-    variable procs [dict create]
-
-    variable argtypes {
-        int { expr {{ Tcl_GetIntFromObj(interp, $obj, &$argname); }}}
-        Tcl_Obj* { expr {{ $argname = $obj; }}}
-        default {
-            if {[string index $argtype end] == "*"} {
-                expr {{ sscanf(Tcl_GetString($obj), "($argtype) 0x%p", &$argname); }}
-            } else {
-                error "Unrecognized argtype $argtype"
+    variable nextHandle 0
+    proc create {} {
+        variable nextHandle
+        set handle "c[incr nextHandle]"
+        uplevel [list namespace eval $handle {
+            variable prelude {
+                #include <tcl.h>
+                #include <inttypes.h>
+                #include <stdint.h>
             }
-        }
-    }
-    ::proc argtype {t h} { variable argtypes; linsert argtypes 0 $t [subst {expr {{$h}}}] }
-
-    variable rtypes {
-        int { expr {{
-            Tcl_SetObjResult(interp, Tcl_NewIntObj(rv));
-            return TCL_OK;
-        }}}
-        Tcl_Obj* { expr {{
-            Tcl_SetObjResult(interp, rv);
-            return TCL_OK;
-        }}}
-        default {
-            if {[string index $rtype end] == "*"} {
-                expr {{
-                    Tcl_SetObjResult(interp, Tcl_ObjPrintf("($rtype) 0x%" PRIxPTR, (uintptr_t) rv));
-                    return TCL_OK;
-                }}
-            } else {
-                error "Unrecognized rtype $rtype"
+            variable code [list]
+            variable procs [dict create]
+
+            variable argtypes {
+                int { expr {{ Tcl_GetIntFromObj(interp, $obj, &$argname); }}}
+                Tcl_Obj* { expr {{ $argname = $obj; }}}
+                default {
+                    if {[string index $argtype end] == "*"} {
+                        expr {{ sscanf(Tcl_GetString($obj), "($argtype) 0x%p", &$argname); }}
+                    } else {
+                        error "Unrecognized argtype $argtype"
+                    }
+                }
             }
-        }
-    }
-    ::proc rtype {t h} { variable rtypes; linsert rtypes 0 $t [subst {expr {{$h}}}] }
-
-    ::proc include {h} {
-        variable code
-        lappend code "#include $h"
-    }
-    ::proc code {newcode} { variable code; lappend code $newcode }
-    ::proc struct {type fields} {
-        variable code
-        lappend code [subst {
-            typedef struct $type $type;
-            struct $type {
-                $fields
-            };
-        }]
-    }
-
-    ::proc "proc" {name args rtype body} {
-        # puts "$name $args $rtype $body"
-        variable argtypes
-        variable rtypes
-
-        set arglist [list]
-        set argnames [list]
-        set loadargs [list]
-        for {set i 0} {$i < [llength $args]} {incr i 2} {
-            set argtype [lindex $args $i]
-            set argname [lindex $args [expr {$i+1}]]
-            lappend arglist "$argtype $argname"
-            lappend argnames $argname
-
-            if {$argtype == "Tcl_Interp*" && $argname == "interp"} { continue }
-
-            set obj [subst {objv\[1 + [llength $loadargs]\]}]
-            lappend loadargs [subst {
-                $argtype $argname;
-                [subst [switch $argtype $argtypes]]
-            }]
-        }
-        if {$rtype == "void"} {
-            set saverv [subst {
-                $name ([join $argnames ", "]);
-                return TCL_OK;
-            }]
-        } else {
-            set saverv [subst {
-                $rtype rv = $name ([join $argnames ", "]);
-                [subst [switch $rtype $rtypes]]
-            }]
-        }
-        
-        set uniquename [string map {":" "_"} [uplevel [list namespace current]]]__$name
-        variable procs
-        dict set procs $name [subst {
-            static $rtype $name ([join $arglist ", "]) {
-                $body
+            ::proc argtype {t h} {
+                variable argtypes
+                set argtypes [linsert $argtypes 0 $t [subst {expr {{$h}}}]]
             }
 
-            static int [set name]_Cmd(ClientData cdata, Tcl_Interp* interp, int objc, Tcl_Obj* const objv\[]) {
-                if (objc != 1 + [llength $loadargs]) {
-                    Tcl_SetResult(interp, "Wrong number of arguments to $name", NULL);
-                    return TCL_ERROR;
+            variable rtypes {
+                int { expr {{
+                    Tcl_SetObjResult(interp, Tcl_NewIntObj(rv));
+                    return TCL_OK;
+                }}}
+                Tcl_Obj* { expr {{
+                    Tcl_SetObjResult(interp, rv);
+                    return TCL_OK;
+                }}}
+                default {
+                    if {[string index $rtype end] == "*"} {
+                        expr {{
+                            Tcl_SetObjResult(interp, Tcl_ObjPrintf("($rtype) 0x%" PRIxPTR, (uintptr_t) rv));
+                            return TCL_OK;
+                        }}
+                    } else {
+                        error "Unrecognized rtype $rtype"
+                    }
                 }
-                [join $loadargs "\n"]
-                $saverv
             }
-        }]
-    }
+            ::proc rtype {t h} {
+                variable rtypes
+                set rtypes [linsert $rtypes 0 $t [subst {expr {{$h}}}]]
+            }
 
-    variable cflags [ switch $tcl_platform(os) {
-        Darwin { expr { [file exists "$::tcl_library/../../Tcl"] ?
-                        [list -I$::tcl_library/../../Headers $::tcl_library/../../Tcl] :
-                        [list -I$::tcl_library/../../include $::tcl_library/../libtcl8.6.dylib]
-                    } }
-        Linux { list -I/usr/include/tcl8.6 -ltcl8.6 }
-    } ]
-    ::proc cflags {args} { variable cflags; lappend cflags {*}$args }
-    ::proc compile {} {
-        variable prelude
-        variable code
-        variable procs
-        variable cflags
-
-        set init [subst {
-            int Cfile_Init(Tcl_Interp* interp) {
-                [join [lmap name [dict keys $procs] { subst {
-                    Tcl_CreateObjCommand(interp, "[uplevel [list namespace current]]::$name", [set name]_Cmd, NULL, NULL);
-                }}] "\n"]
-                return TCL_OK;
+            ::proc include {h} {
+                variable code
+                lappend code "#include $h"
             }
-        }]
-        set sourcecode [join [list \
-                                  $prelude \
-                                  {*}$code \
-                                  {*}[dict values $procs] \
-                                  $init \
-                                 ] "\n"]
+            ::proc code {newcode} { variable code; lappend code $newcode }
+            ::proc struct {type fields} {
+                variable code
+                lappend code [subst {
+                    typedef struct $type $type;
+                    struct $type {
+                        $fields
+                    };
+                }]
+            }
+
+            ::proc "proc" {name args rtype body} {
+                # puts "$name $args $rtype $body"
+                variable argtypes
+                variable rtypes
+
+                set arglist [list]
+                set argnames [list]
+                set loadargs [list]
+                for {set i 0} {$i < [llength $args]} {incr i 2} {
+                    set argtype [lindex $args $i]
+                    set argname [lindex $args [expr {$i+1}]]
+                    lappend arglist "$argtype $argname"
+                    lappend argnames $argname
+
+                    if {$argtype == "Tcl_Interp*" && $argname == "interp"} { continue }
+
+                    set obj [subst {objv\[1 + [llength $loadargs]\]}]
+                    lappend loadargs [subst {
+                        $argtype $argname;
+                        [subst [switch $argtype $argtypes]]
+                    }]
+                }
+                if {$rtype == "void"} {
+                    set saverv [subst {
+                        $name ([join $argnames ", "]);
+                        return TCL_OK;
+                    }]
+                } else {
+                    set saverv [subst {
+                        $rtype rv = $name ([join $argnames ", "]);
+                        [subst [switch $rtype $rtypes]]
+                    }]
+                }
 
-        # puts "=====================\n$sourcecode\n====================="
+                set uniquename [string map {":" "_"} [uplevel [list namespace current]]]__$name
+                variable procs
+                dict set procs $name [subst {
+                    static $rtype $name ([join $arglist ", "]) {
+                        $body
+                    }
+
+                    static int [set name]_Cmd(ClientData cdata, Tcl_Interp* interp, int objc, Tcl_Obj* const objv\[\]) {
+                        if (objc != 1 + [llength $loadargs]) {
+                            Tcl_SetResult(interp, "Wrong number of arguments to $name", NULL);
+                            return TCL_ERROR;
+                        }
+                        [join $loadargs "\n"]
+                        $saverv
+                    }
+                }]
+            }
 
-        set cfd [file tempfile cfile cfile.c]; puts $cfd $sourcecode; close $cfd
-        exec cc -Wall -g -shared -fPIC {*}$cflags $cfile -o [file rootname $cfile][info sharedlibextension]
-        load [file rootname $cfile][info sharedlibextension] cfile
+            variable cflags [switch $tcl_platform(os) {
+                Darwin { expr { [file exists "$::tcl_library/../../Tcl"] ?
+                                [list -I$::tcl_library/../../Headers $::tcl_library/../../Tcl] :
+                                [list -I$::tcl_library/../../include $::tcl_library/../libtcl8.6.dylib]
+                            } }
+                Linux { list -I/usr/include/tcl8.6 -ltcl8.6 }
+            }]
+            ::proc cflags {args} { variable cflags; lappend cflags {*}$args }
+            ::proc compile {} {
+                variable prelude
+                variable code
+                variable procs
+                variable cflags
+
+                set init [subst {
+                    int Cfile_Init(Tcl_Interp* interp) {
+                        [join [lmap name [dict keys $procs] { subst {
+                            Tcl_CreateObjCommand(interp, "[uplevel [list namespace current]]::$name", [set name]_Cmd, NULL, NULL);
+                        }}] "\n"]
+                        return TCL_OK;
+                    }
+                }]
+                set sourcecode [join [list \
+                                          $prelude \
+                                          {*}$code \
+                                          {*}[dict values $procs] \
+                                          $init \
+                                         ] "\n"]
+
+                # puts "=====================\n$sourcecode\n====================="
+
+                set cfd [file tempfile cfile cfile.c]; puts $cfd $sourcecode; close $cfd
+                exec cc -Wall -g -shared -fPIC {*}$cflags $cfile -o [file rootname $cfile][info sharedlibextension]
+                load [file rootname $cfile][info sharedlibextension] cfile
+
+                set code [list]
+                set procs [dict create]
+            }
 
-        set code [list]
-        set procs [dict create]
+            namespace export *
+            namespace ensemble create
+        }]
+        return $handle
     }
-
-    namespace export *
+    namespace export create
     namespace ensemble create
 }
 
diff --git a/lib/trie.tcl b/lib/trie.tcl
index 6d9b5ac1..ddcbb913 100644
--- a/lib/trie.tcl
+++ b/lib/trie.tcl
@@ -1,7 +1,8 @@
 namespace eval ctrie {
-    c include <stdlib.h>
-    c include <string.h>
-    c struct trie_t {
+    rename [c create] cc
+    cc include <stdlib.h>
+    cc include <string.h>
+    cc struct trie_t {
         Tcl_Obj* key;
 
         int id; // or -1
@@ -10,7 +11,7 @@ namespace eval ctrie {
         trie_t* branches[];
     }
 
-    c proc create {} trie_t* {
+    cc proc create {} trie_t* {
         size_t size = sizeof(trie_t) + 10*sizeof(trie_t*);
         trie_t* ret = ckalloc(size); memset(ret, 0, size);
         *ret = (trie_t) {
@@ -21,7 +22,7 @@ namespace eval ctrie {
         return ret;
     }
 
-    c proc addImpl {trie_t** trie int wordc Tcl_Obj** wordv int id} void {
+    cc proc addImpl {trie_t** trie int wordc Tcl_Obj** wordv int id} void {
         if (wordc == 0) {
             (*trie)->id = id;
             return;
@@ -63,7 +64,7 @@ namespace eval ctrie {
 
         addImpl(match, wordc - 1, wordv + 1, id);
     }
-    c proc add {Tcl_Interp* interp Tcl_Obj* trieVar Tcl_Obj* clause int id} void {
+    cc proc add {Tcl_Interp* interp Tcl_Obj* trieVar Tcl_Obj* clause int id} void {
         int objc; Tcl_Obj** objv;
         if (Tcl_ListObjGetElements(interp, clause, &objc, &objv) != TCL_OK) {
             exit(1);
@@ -74,7 +75,7 @@ namespace eval ctrie {
         Tcl_ObjSetVar2(interp, trieVar, NULL, Tcl_ObjPrintf("(trie_t*) 0x%" PRIxPTR, (uintptr_t) trie), 0);
     }
 
-    c proc removeImpl {trie_t* trie int wordc Tcl_Obj** wordv} int {
+    cc proc removeImpl {trie_t* trie int wordc Tcl_Obj** wordv} int {
         if (wordc == 0) return 1;
 
         for (int j = 0; j < trie->nbranches; j++) {
@@ -99,7 +100,7 @@ namespace eval ctrie {
         }
         return 0;
     }
-    c proc remove_ {Tcl_Interp* interp Tcl_Obj* trieVar Tcl_Obj* clause} void {
+    cc proc remove_ {Tcl_Interp* interp Tcl_Obj* trieVar Tcl_Obj* clause} void {
         int objc; Tcl_Obj** objv;
         if (Tcl_ListObjGetElements(interp, clause, &objc, &objv) != TCL_OK) {
             exit(1);
@@ -108,8 +109,8 @@ namespace eval ctrie {
         removeImpl(trie, objc, objv);
     }
 
-    c proc lookupImpl {Tcl_Interp* interp Tcl_Obj* results
-                       trie_t* trie int wordc Tcl_Obj** wordv} void {
+    cc proc lookupImpl {Tcl_Interp* interp Tcl_Obj* results
+                        trie_t* trie int wordc Tcl_Obj** wordv} void {
         if (wordc == 0) {
             if (trie->id != -1) {
                 Tcl_ListObjAppendElement(interp, results, Tcl_ObjPrintf("%d", trie->id));
@@ -133,7 +134,7 @@ namespace eval ctrie {
             }
         }
     }
-    c proc lookup {Tcl_Interp* interp trie_t* trie Tcl_Obj* pattern} Tcl_Obj* {
+    cc proc lookup {Tcl_Interp* interp trie_t* trie Tcl_Obj* pattern} Tcl_Obj* {
         int objc; Tcl_Obj** objv;
         if (Tcl_ListObjGetElements(interp, pattern, &objc, &objv) != TCL_OK) {
             exit(1);
@@ -143,7 +144,7 @@ namespace eval ctrie {
         return results;
     }
 
-    c proc tclify {trie_t* trie} Tcl_Obj* {
+    cc proc tclify {trie_t* trie} Tcl_Obj* {
         int objc = 2 + trie->nbranches;
         Tcl_Obj* objv[objc];
         objv[0] = trie->key ? trie->key : Tcl_ObjPrintf("ROOT");
@@ -178,7 +179,7 @@ namespace eval ctrie {
         return "digraph { rankdir=LR; [subdot {} $trie] }"
     }
 
-    c compile
+    cc compile
     rename remove_ remove
     namespace export create add remove lookup tclify dot
     namespace ensemble create