[Tinyos-commits] CVS: tinyos-1.x/tos/lib/VM/languages/motlle/standalone scheme.c, 1.13, 1.14

[David Gay]

Update of /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone
In directory sc8-pr-cvs1.sourceforge.net:/tmp/cvs-serv17035

Modified Files:
	scheme.c 
Log Message:
named let


Index: scheme.c
===================================================================
RCS file: /cvsroot/tinyos/tinyos-1.x/tos/lib/VM/languages/motlle/standalone/scheme.c,v
retrieving revision 1.13
retrieving revision 1.14
diff -C2 -d -r1.13 -r1.14
*** scheme.c	18 Nov 2005 22:28:30 -0000	1.13
--- scheme.c	18 Nov 2005 22:55:49 -0000	1.14
***************
*** 49,52 ****
--- 49,60 ----
  }
  
+ static value nthtail(struct list *l, int n)
+ {
+   while (--n)
+     l = l->cdr;
+ 
+   return l;
+ }
+ 
  static value nth(struct list *l, int n)
  {
***************
*** 579,595 ****
  }
  
! static int check_binding(location l, value binding, int extra)
  {
    if (list_length(binding) != 2 + extra)
      {
        log_error(l, "invalid variable binding");
!       return FALSE;
!     }
!   if (!TYPE(((struct list *)binding)->car, type_symbol))
!     {
!       log_error(l, "first element of binding list must be a symbol");
!       return FALSE;
      }
!   return TRUE;
  }
  
--- 587,606 ----
  }
  
! static struct symbol *check_binding(location l, value binding, int extra)
  {
+   value sym;
+ 
    if (list_length(binding) != 2 + extra)
      {
        log_error(l, "invalid variable binding");
!       return NULL;
      }
! 
!   sym = ((struct list *)binding)->car;
!   if (TYPE(sym, type_symbol))
!     return sym;
! 
!   log_error(l, "first element of binding list must be a symbol");
!   return NULL;
  }
  
***************
*** 619,623 ****
    if (TYPE(bindings, type_pair))
      {
!       int ok = check_binding(l, bindings->car, extra);
  
        GCPRO1(bindings);
--- 630,634 ----
    if (TYPE(bindings, type_pair))
      {
!       int ok = check_binding(l, bindings->car, extra) != NULL;
  
        GCPRO1(bindings);
***************
*** 645,650 ****
--- 656,716 ----
  }
  
+ static void compile_named_let_mgc(location l, struct list *args, bool discard, fncode fn)
+ {
+   struct symbol *name, *parm;
+   struct list *bindings, *parameters = NULL, *last_parameter = NULL;
+   const char *cname;
+   int nargs = 0;
+ 
+   if (list_length(args) < 3)
+     {
+       log_error(l, "no body in named let");
+       return;
+     }
+ 
+   env_block_push(NULL);
+   cname = sym2str(fnmemory(fn), args->car);
+   env_declare(str2vlist(fnmemory(fn), cname));
+ 
+   bindings = nth(args, 2); 
+   GCPRO2(bindings, args);
+   GCPRO2(parameters, last_parameter);
+   for (; TYPE(bindings, type_pair); bindings = bindings->cdr)
+     if ((parm = check_binding(l, bindings->car, 0)))
+       {
+ 	struct list *parmtail = alloc_list(parm, NULL);
+ 
+ 	if (!parameters)
+ 	  parameters = last_parameter = parmtail;
+ 	else
+ 	  {
+ 	    last_parameter->cdr = parmtail;
+ 	    last_parameter = parmtail;
+ 	  }
+ 
+ 	sgen_binding_init_mgc(l, bindings->car, fn);
+ 	nargs++;
+       }
+   if (bindings)
+     log_error(l, "invalid bindings");
+   if (nargs >= 16)
+     log_error(l, "no more than 15 arguments allowed");
+   name = args->car;
+   sgen_function_mgc(l, name->name, parameters, nthtail(args, 3), FALSE, fn);
+   sgen_assign_mgc(l, cname, FALSE, fn);
+   ins0(OPmexec4 + (nargs & 0xf), fn);
+   if (discard)
+     ins0(OPmpop, fn);
+   env_block_pop();
+   GCPOP(4);
+ }
+ 
  static void compile_let_mgc(location l, struct list *args, bool discard, fncode fn)
  {
+   if (TYPE(args->car, type_symbol))
+     {
+       compile_named_let_mgc(l, args, discard, fn);
+       return;
+     }
    env_block_push(NULL);
    GCPRO1(args);
***************
*** 682,686 ****
    if (TYPE(bindings, type_pair))
      {
!       int ok = check_binding(l, bindings->car, 0);
  
        GCPRO1(bindings);
--- 748,752 ----
    if (TYPE(bindings, type_pair))
      {
!       int ok = check_binding(l, bindings->car, 0) != NULL;
  
        GCPRO1(bindings);