[George Peter Staplin] Oct 12, 2007 - I wanted [co-routines] from the C level, so I implemented some C code using the ucontext functions.  Unfortunately Tcl's stack checking in unix-like systems breaks this, so you'll need to build a custom tclsh by editing tcl/unix/tclUnixInit.c and changing #undef TCL_NO_STACK_CHECK to #define TCL_NO_STACK_CHECK.  The stack checking is somewhat of a hack IMO anyway.

Basically with the ucontext functions each coroutine has a separate stack.  It's much cleaner and more reliable than trying to work with setjmp and longjmp.

 /* Tcor by George Peter Staplin */
 
 #include <tcl.h>
 #include <stdlib.h>
 #include <ucontext.h>
 
 #define OBJ_CMD_ARGS ClientData clientData, Tcl_Interp *interp, int objc, Tcl_Obj *const objv[]
 
 #define defcmd(func,name) \
  Tcl_CreateObjCommand (interp, name, func, (ClientData) NULL, (Tcl_CmdDeleteProc *) NULL)
 
 #define STACK_SIZE 4194304
 
 struct lwt {
  ucontext_t context;
  struct lwt *previous, *next;
  void *ptr;
 };
 
 static struct lwt *lwts = NULL;
 static struct lwt *lwt_current = NULL;
 static struct lwt *lwt_to_free = NULL;
 static int lwt_total = 0;
 static ucontext_t lwt_reaper;
 
 static void lwt_exit (void);
 static void lwt_init (void);
 static void lwt_spawn (void (*func) (void), void *ptr);
 static void lwt_yield (void);
 static int tcor_spawn (OBJ_CMD_ARGS);
 static int tcor_yield (OBJ_CMD_ARGS);
 int Tcor_Init (Tcl_Interp *interp);
 
 static void
 lwt_reap (void) {
  struct lwt *n; 
 
  free (lwt_to_free->context.uc_stack.ss_sp);
  free (lwt_to_free);
  lwt_to_free = NULL;
  n = lwts;
  lwt_current = n;
 
  if (setcontext (&n->context)) {
   perror ("lwt_exit :- setcontext");
   abort ();
  }
  /* NOTREACHED */
 }
 
 static void
 lwt_exit (void) {
  struct lwt *l = lwt_current;
 
  /* delink the lwt */ 
  if (l->previous) {
   l->previous = l->next;
   if (l->next) {
    l->next->previous = l->previous;
   }
  } else {
   lwts = l->next;
   if (lwts) {
    lwts->previous = NULL; 
   }
  }
 
  lwt_to_free = l;
 
  if (setcontext (&lwt_reaper)) {
   perror ("lwt_exit :- setcontext");
   abort ();
  }
  /* NOTREACHED */
 }
 
 static void
 lwt_init ( void ) {
  struct lwt *l;
 
  l = malloc (sizeof *l);
  if (NULL == l) {
   perror ("lwt_init :- malloc");
   abort ();
  }
 
  l->ptr = NULL;
  l->previous = NULL;
  l->next = lwts;
  lwts = l;
 
  lwt_current = l;
  ++lwt_total;
  
  if (getcontext (&l->context)) {
   perror ("lwt_init :- getcontext");
   abort ();
  }
 
 /* l->context.uc_link = NULL; */
 
  /* From the manual for NetBSD it was unclear if this was necessary or not prior to a makecontext. */
  if (getcontext (&lwt_reaper)) {
   perror ("lwt_init :- getcontext lwt_reaper");
   abort ();
  }
 
  lwt_reaper.uc_link = NULL;
  lwt_reaper.uc_stack.ss_sp = malloc (STACK_SIZE);
  if (NULL == lwt_reaper.uc_stack.ss_sp) {
   abort ();
  }
  lwt_reaper.uc_stack.ss_flags = 0;
  lwt_reaper.uc_stack.ss_size = STACK_SIZE;
 
  makecontext (&lwt_reaper, lwt_reap, 0);
 }
 
 
 static void
 lwt_spawn ( void (*func) (void), void *ptr) {
  struct lwt *l;
 
  l = malloc (sizeof *l);
  if (NULL == l) {
   perror ("lwt_spawn :- malloc lwt");
   abort ();
  }
 
  l->ptr = ptr;
  l->previous = NULL;
  l->next = lwts;
  lwts = l;
 
  if (getcontext (&l->context)) {
   perror ("getcontext");
   abort ();
  }
 
  l->context.uc_link = NULL;
  l->context.uc_stack.ss_sp = malloc (STACK_SIZE);
  if (NULL == l->context.uc_stack.ss_sp) {
   perror ("lwt_spawn :- malloc stack");
   abort ();
  }
  l->context.uc_stack.ss_flags = 0;
  l->context.uc_stack.ss_size = STACK_SIZE;
 
  makecontext (&l->context, func, 0);
  ++lwt_total;
 }
 
 static void
 lwt_yield ( void ) {
  struct lwt *l = lwt_current;
  struct lwt *n;
 
  n = l->next;
  if (NULL == n) {
   n = lwts;
  }
 
  lwt_current = n;
  
  if (l == n) {
   /* There is only one context. */
   return;
  }
   
  if (swapcontext (&l->context, &n->context)) {
   perror ("lwt_yield :- swapcontext");
   abort ();
  }
  /* NOTREACHED */
 }
 
 static void
 tcor_spawn_start (void) {
  Tcl_Obj *cmd = lwt_current->ptr;
  Tcl_Interp *interp;
 
  interp = Tcl_CreateInterp ();
  if (TCL_OK != Tcl_Init (interp)) {
   fprintf (stderr, "Tcl_Init error: %s\n", Tcl_GetStringResult (interp));
   goto error;
  }
  defcmd (tcor_spawn, "tcor-spawn");
  defcmd (tcor_yield, "tcor-yield");
 
  if (TCL_ERROR == Tcl_EvalObjEx (interp, cmd, TCL_EVAL_GLOBAL | TCL_EVAL_DIRECT)) {
   fprintf (stderr, "spawned task evaluation error: %s\n", Tcl_GetStringResult (interp));
  }
 error:
  Tcl_DecrRefCount (cmd);
  Tcl_DeleteInterp (interp);
  lwt_exit ();
 } 
 
 static int
 tcor_spawn (OBJ_CMD_ARGS) {
  Tcl_Obj *cmd;
  
  if (2 != objc) {
   Tcl_WrongNumArgs (interp, 1, objv, "command-list");
   return TCL_ERROR;
  }
  
  cmd = Tcl_DuplicateObj (objv[1]);
  Tcl_IncrRefCount (cmd);
  lwt_spawn (tcor_spawn_start, cmd);
  
  return TCL_OK;
 }
 
 static int
 tcor_yield (OBJ_CMD_ARGS) {
  lwt_yield (); 
  return TCL_OK;
 }
 
 int Tcor_Init (Tcl_Interp *interp) {
  if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
   return TCL_ERROR;
 
  defcmd (tcor_spawn, "tcor-spawn");
  defcmd (tcor_yield, "tcor-yield");
 
  lwt_init ();
 
  return TCL_OK;
 }

----
Test code

 load ./tcor.so

 set cmd {
 proc hello {} {
  while 1 {
   puts HELLO
   tcor-yield
  }
 }
 hello
 }
 proc main {} {
  tcor-spawn $::cmd
  package require Tk
  puts MAIN
  tcor-yield 
  vwait forever
 }
 main
----