[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.

[George Peter Staplin] Nov 13, 2007 - The Tcl core now works better with this.  I've also built a new version 0.2.  I've added the ability for coroutines to have mailboxes (inspired by Erlang).
----
/* 
   Tcor 0.2 by George Peter Staplin
 
  gcc -shared tcor.c -DUSE_TCL_STUBS -I/usr/local/lib -L/usr/local/lib -ltclstub8.5 -o tcor.so
 
  */
 
 #include <tcl.h>
 #include <stdlib.h>
 #include <string.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 /* 4 MB */
 #define REAPER_STACK_SIZE 1048576 /* 1 MB */
 
 
 struct lwt_message {
   unsigned char *bytes;
   size_t length;
   struct lwt_message *next;
 };
 
 struct lwt {
   ucontext_t context;
   struct lwt_message *messages;
   int id;
   void *ptr;
 };
 
 static int lwt_initialized = 0;
 
 static struct lwt **lwt_table = NULL;
 static int lwt_allocated = 0;
 static struct lwt *lwt_current = NULL;
 static struct lwt *lwt_to_free = NULL;
 static int lwt_total = 0;
 static ucontext_t lwt_reaper;
 
 static struct lwt *lwt_alloc (void);
 static void lwt_enlarge_table (void);
 static void lwt_exit (void);
 static void lwt_init (void);
 static int 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);
 static int tcor_send_message (OBJ_CMD_ARGS);
 static int tcor_get_message (OBJ_CMD_ARGS);
 int Tcor_Init (Tcl_Interp *interp);
 
 static struct lwt *
 lwt_alloc (void) {
   struct lwt *l;
 
   l = (void *)Tcl_Alloc (sizeof *l);
   if (getcontext (&l->context))
     perror ("getcontext");
 
   l->messages = NULL;
   l->id = -1;
   l->ptr = NULL;
 
   return l;
 }
 
 static void
 lwt_enlarge_table (void) {
   struct lwt **newtable;
   int newtablesize = lwt_allocated * 2;
   int i;
 
   newtable = (void *)Tcl_Alloc (sizeof *newtable * newtablesize);
   for (i = 0; i < newtablesize; ++i) {
     newtable[i] = NULL;
   }
 
   for (i = 0; i < lwt_allocated; ++i) {
     newtable[i] = lwt_table[i];
   }
 
   Tcl_Free ((void *)lwt_table);
   lwt_table = newtable;
   lwt_allocated = newtablesize;
 }
 
 
 static void
 lwt_reap (void) {
   struct lwt *n; 
   int i;
   
   free (lwt_to_free->context.uc_stack.ss_sp);
   Tcl_Free ((void *)lwt_to_free);
   lwt_to_free = NULL;
 
   /* Select a new task */
   for (i = 0; i < lwt_allocated; ++i) {
     if (lwt_table[i]) {
       n = lwt_table[i];
       break;
     }
   }
 
   lwt_current = n;
   if (setcontext (&n->context)) {
     perror ("lwt_exit - setcontext");
     abort ();
   }
   /* NOTREACHED */
 }
 
 static void
 lwt_exit (void) {
   struct lwt *l = lwt_current;
 
   lwt_table[l->id] = NULL;
   lwt_to_free = l;
 
   --lwt_total;
   
   /* We can't just free the task now, because it's executing with the stack
    * we need to free.
    */
 
   if (setcontext (&lwt_reaper)) {
     perror ("lwt_exit - setcontext");
     abort ();
   }
   /* NOTREACHED */
 }
 
 static void
 lwt_init ( void ) {
   struct lwt *l;
   int i;
   
   if (lwt_initialized)
     return;
 
   l = lwt_alloc ();
 
   lwt_allocated = 20;
   lwt_table = (void *)Tcl_Alloc (sizeof *lwt_table * lwt_allocated);
   for (i = 0; i < lwt_allocated; ++i) {
     lwt_table[i] = NULL;
   }
   
   l->id = 0;
   lwt_table[/*id*/ 0] = l;
   lwt_current = l;
   ++lwt_total;
   l->context.uc_link = NULL;
   l->context.uc_stack.ss_size = 0;
   l->context.uc_stack.ss_sp = NULL;
   
 
   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) {
     perror ("malloc lwt_reaper stack");
     abort ();
   }
   lwt_reaper.uc_stack.ss_flags = 0;
   lwt_reaper.uc_stack.ss_size = STACK_SIZE;
   
   makecontext (&lwt_reaper, lwt_reap, 0);
 
   lwt_initialized = 1;
 }
 
 
 static int
 lwt_spawn ( void (*func) (void), void *ptr) {
   struct lwt *l;
   int id;
 
   l = lwt_alloc ();
   l->ptr = ptr;
   ++lwt_total;
 
   if (lwt_total >= lwt_allocated) {
     lwt_enlarge_table ();
   }
 
   /* Find first free entry */
   for (id = 0; id < lwt_allocated; ++id) {
     if (NULL == lwt_table[id]) {
       break;
     }
   }
 
   lwt_table[id] = l;
   l->id = id;
     
   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);  
 
   return id;
 }
 
 static void
 lwt_yield ( void ) {
   struct lwt *l = lwt_current;
   struct lwt *n = NULL;
   int id = -1;
 
   id = l->id + 1;
   while (id < lwt_allocated) {
     if (lwt_table[id]) {
       n = lwt_table[id];
       break;
     }
     ++id;
   }
   if (NULL == n) {
     for (id = 0; id < lwt_allocated; ++id) {
       if (lwt_table[id]) {
 	n = lwt_table[id];
 	break;
       }
     }
   }
  
   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;
   }
 
   if (TCL_OK != Tcor_Init (interp)) {
     fprintf (stderr, "Tcl_Init error: %s\n", Tcl_GetStringResult (interp));
     goto error;
   }
 
   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;
   int id;
   
   if (2 != objc) {
     Tcl_WrongNumArgs (interp, 1, objv, "script");
     return TCL_ERROR;
   }
   
   cmd = Tcl_DuplicateObj (objv[1]);
   Tcl_IncrRefCount (cmd);
   Tcl_SetObjResult (interp, Tcl_NewIntObj (lwt_spawn (tcor_spawn_start, cmd)));
   
   return TCL_OK;
 }
 
 static int
 tcor_yield (OBJ_CMD_ARGS) {
   if (1 != objc) { 
     Tcl_WrongNumArgs (interp, 1, objv, "");
     return TCL_ERROR;
   }
 
   lwt_yield (); 
   return TCL_OK;
 }
 
 static struct lwt *tcor_get_lwt (Tcl_Interp *interp, Tcl_Obj *obj, int *id) {
   struct lwt *l;
 
   if (TCL_OK != Tcl_GetIntFromObj (interp, obj, id))
     return NULL;
 
   if (*id < 0 || *id >= lwt_allocated) {
     Tcl_SetResult (interp, "id out of range", TCL_STATIC);
     return NULL;
   }
 
   l = lwt_table[*id];
   if (NULL == l) {
     Tcl_SetResult (interp, "id is invalid", TCL_STATIC);
     return NULL;
   }
   return l;
 }
 
 static int
 tcor_send_message (OBJ_CMD_ARGS) {
   struct lwt *l;
   struct lwt_message *m;
   unsigned char *b;
   int len;
   int id;
 
   if (3 != objc) {
     Tcl_WrongNumArgs (interp, 1, objv, "id obj");
     return TCL_ERROR;
   }
 
   l = tcor_get_lwt (interp, objv[1], &id);
   if (NULL == l)
     return TCL_ERROR;
 
   b = Tcl_GetByteArrayFromObj (objv[2], &len);
 
   m = (void *)Tcl_Alloc (sizeof *m);
   m->bytes = (void *)Tcl_Alloc (len);
   m->length = len;
   memcpy (m->bytes, b, len);
   m->next = NULL;
 
   if (NULL == l->messages) {
     l->messages = m;
   } else {
     struct lwt_message *mi;
     mi = l->messages;
     while (mi->next) {
       mi = mi->next;
     }
     mi->next = m;   
   }
 
   return TCL_OK;
 }
 
 static int
 tcor_get_message (OBJ_CMD_ARGS) {
   int id;
   struct lwt *l;
   Tcl_Obj *r;
 
   if (1 != objc) {
     Tcl_WrongNumArgs (interp, 1, objv, "");
     return TCL_ERROR;
   }
 
  again:
   l = lwt_current;
 
   if (NULL == l->messages) {
     lwt_yield ();
     goto again;
   } else {
     struct lwt_message *m = l->messages;
 
     r = Tcl_NewByteArrayObj (m->bytes, m->length);
 
     l->messages = m->next;
 
     Tcl_Free ((void *)m->bytes);
     Tcl_Free ((void *)m);
   }
 
   Tcl_SetObjResult (interp, r);
 
   return TCL_OK;
 }
 
 int Tcor_Init (Tcl_Interp *interp) {
   if (NULL == Tcl_InitStubs (interp, TCL_VERSION, 0))
     return TCL_ERROR;
 
   if (TCL_ERROR == Tcl_PkgProvide (interp, "tcor", "0.2"))
     return TCL_ERROR;
   
   defcmd (tcor_spawn, "tcor-spawn");
   defcmd (tcor_yield, "tcor-yield");
   defcmd (tcor_send_message, "tcor-send-message");
   defcmd (tcor_get_message, "tcor-get-message");
   lwt_init ();
   
   return TCL_OK;
 }

----
New test code:
 set dir [file dirname [info script]]
 load [file join $dir tcor.so]
 package require Tk
 
 set bozo {
     proc bozo {} {
 	while 1 {
 	    puts "BOZO SAYS:[tcor-get-message]"
 	}   
     }
     bozo
 }
 
 set clown {
     proc clown {} {
 	while 1 {
 	    puts "CLOWN SAYS:[tcor-get-message]"
 	}
     }
     clown
 }
 
 
 proc main {} {
     set bozo [tcor-spawn $::bozo]
     set clown [tcor-spawn $::clown]
 
     puts "BOZO:$bozo"
     puts "CLOWN:$clown"
 
     pack [button .b -text "Message Bozo!" \
 	      -command [list tcor-send-message $bozo HIHIHIHIHIHIHI!]]
 
     pack [button .b2 -text "Message Clown!" \
 	      -command [list tcor-send-message $clown HAHAHAHAHAHA!]] 
     pack [button .b3 -text Yield \
 	      -command [list tcor-yield]]
 
 }
 main

----
[CGM]: This test code just writes MAIN\nHELLO and then hangs on the vwait.
I changed it to:

 load ./tcor.so

 set cmd {
  while 1 {
   puts HELLO
   tcor-yield
  }
 }

 tcor-spawn $::cmd
  
 while 1 {
  puts MAIN
  tcor-yield
  after 1000
 }

Which switches between the two loops printing MAIN\nHELLO\nMAIN\nHELLO ...etc.

[GPS]: Thanks [CGM].

----
[Category Control Structure]