core: mes: Prepare for M2-Planet.
authorJan Nieuwenhuizen <janneke@gnu.org>
Sun, 12 Aug 2018 14:53:21 +0000 (16:53 +0200)
committerJan Nieuwenhuizen <janneke@gnu.org>
Sun, 12 Aug 2018 14:53:21 +0000 (16:53 +0200)
* src/mes.c (cal): Refactor to use if instead of switch.
(eval_apply): Likewise.

src/mes.c

index 1e34214be0e5bfb461b7cfe4aa514e8b2d5c13a2..46020d13329d2e4777f9623505d0021d9334fb6c 100644 (file)
--- a/src/mes.c
+++ b/src/mes.c
@@ -56,26 +56,49 @@ SCM r3 = 0;
 SCM g_macros = 1;
 SCM g_ports = 1;
 
-
+#if __M2_PLANET__
+CONSTANT TCHAR          0
+CONSTANT TCLOSURE       1
+CONSTANT TCONTINUATION  2
+CONSTANT TFUNCTION      3
+CONSTANT TKEYWORD       4
+CONSTANT TMACRO         5
+CONSTANT TNUMBER        6
+CONSTANT TPAIR          7
+CONSTANT TPORT          8
+CONSTANT TREF           9
+CONSTANT TSPECIAL      10
+CONSTANT TSTRING       11
+CONSTANT TSYMBOL       12
+CONSTANT TVALUES       13
+CONSTANT TVARIABLE     14
+CONSTANT TVECTOR       15
+CONSTANT TBROKEN_HEART 16
+#else // !__M2_PLANET__
 enum type_t {TCHAR, TCLOSURE, TCONTINUATION, TFUNCTION, TKEYWORD, TMACRO, TNUMBER, TPAIR, TPORT, TREF, TSPECIAL, TSTRING, TSYMBOL, TVALUES, TVARIABLE, TVECTOR, TBROKEN_HEART};
+#endif // !__M2_PLANET__
 
-#if !_POSIX_SOURCE
+typedef SCM (*function0_t) (void);
+typedef SCM (*function1_t) (SCM);
+typedef SCM (*function2_t) (SCM, SCM);
+typedef SCM (*function3_t) (SCM, SCM, SCM);
+typedef SCM (*functionn_t) (SCM);
+#if !POSIX
 struct scm {
   enum type_t type;
   SCM car;
   SCM cdr;
 };
 struct function {
-  long (*function) (void);
+#if __M2_PLANET__
+  FUNCTION function;
+#else // !__M2_PLANET__
+  SCM (*function) (SCM);
+#endif // !__M2_PLANET__
   long arity;
   char *name;
 };
 #else
-typedef SCM (*function0_t) (void);
-typedef SCM (*function1_t) (SCM);
-typedef SCM (*function2_t) (SCM, SCM);
-typedef SCM (*function3_t) (SCM, SCM, SCM);
-typedef SCM (*functionn_t) (SCM);
 struct function {
   union {
     function0_t function0;
@@ -688,30 +711,74 @@ pairlis (SCM x, SCM y, SCM a)
 SCM
 call (SCM fn, SCM x)
 {
-  if ((FUNCTION (fn).arity > 0 || FUNCTION (fn).arity == -1)
+#if __M2_PLANET__
+  struct function *f = FUNCTION (fn);
+#else
+  struct function *f = &FUNCTION (fn);
+#endif
+  int arity = f->arity;
+  if ((arity > 0 || arity == -1)
       && x != cell_nil && TYPE (CAR (x)) == TVALUES)
     x = cons (CADAR (x), CDR (x));
-  if ((FUNCTION (fn).arity > 1 || FUNCTION (fn).arity == -1)
+  if ((arity > 1 || arity == -1)
       && x != cell_nil && TYPE (CDR (x)) == TPAIR && TYPE (CADR (x)) == TVALUES)
     x = cons (CAR (x), cons (CDADAR (x), CDR (x)));
-  switch (FUNCTION (fn).arity)
+
+#if __M2_PLANET__
+  FUNCTION fp = f->function;
+  if (arity == 0)
+    return fp ();
+  else if (arity == 1)
+    return fp (CAR (x));
+  else if (arity == 2)
+    return fp (CAR (x), CADR (x));
+  else if (arity == 3)
+    return fp (CAR (x), CADR (x), CAR (CDDR (x)));
+  else if (arity == -1)
+    return fp (x);
+#elif !POSIX
+  if (arity == 0)
     {
-#if __MESC__ || !_POSIX_SOURCE
-    case 0: return (FUNCTION (fn).function) ();
-    case 1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (CAR (x));
-    case 2: return ((SCM(*)(SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x));
-    case 3: return ((SCM(*)(SCM,SCM,SCM))(FUNCTION (fn).function)) (CAR (x), CADR (x), CAR (CDDR (x)));
-    case -1: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
-    default: return ((SCM(*)(SCM))(FUNCTION (fn).function)) (x);
-#else
-    case 0: return FUNCTION (fn).function0 ();
-    case 1: return FUNCTION (fn).function1 (CAR (x));
-    case 2: return FUNCTION (fn).function2 (CAR (x), CADR (x));
-    case 3: return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
-    case -1: return FUNCTION (fn).functionn (x);
-#endif
+      //function0_t fp = f->function;
+      SCM (*fp) (void) = f->function;
+      return fp ();
     }
-
+  else if (arity == 1)
+    {
+      //function1_t fp = f->function;
+      SCM (*fp) (SCM) = f->function;
+      return fp (CAR (x));
+    }
+  else if (arity == 2)
+    {
+      //function2_t fp = f->function;
+      SCM (*fp) (SCM, SCM) = f->function;
+      return fp (CAR (x), CADR (x));
+    }
+  else if (arity == 3)
+    {
+      //function3_t fp = f->function;
+      SCM (*fp) (SCM, SCM, SCM) = f->function;
+      return fp (CAR (x), CADR (x), CAR (CDDR (x)));
+    }
+  else if (arity == -1)
+    {
+      //functionn_t fp = f->function;
+      SCM (*fp) (SCM) = f->function;
+      return fp (x);
+    }
+#else
+  if (arity == 0)
+    return FUNCTION (fn).function0 ();
+  else if (arity == 1)
+    return FUNCTION (fn).function1 (CAR (x));
+  else if (arity == 2)
+    return FUNCTION (fn).function2 (CAR (x), CADR (x));
+  else if (arity == 3)
+    return FUNCTION (fn).function3 (CAR (x), CADR (x), CAR (CDDR (x)));
+  else if (arity == -1)
+    return FUNCTION (fn).functionn (x);
+#endif //! (__M2_PLANET__ || !POSIX)
   return cell_unspecified;
 }
 
@@ -720,29 +787,25 @@ assq (SCM x, SCM a)
 {
   if (TYPE (a) != TPAIR)
     return cell_f;
-  switch (TYPE (x))
-    {
-    case TCHAR:
-    case TNUMBER:
+  int t = TYPE (x);
+  if (t == TCHAR
+      || t == TNUMBER)
       {
         SCM v = VALUE (x);
         while (a != cell_nil && v != VALUE (CAAR (a)))
           a = CDR (a);
-        break;
       }
-    case TKEYWORD:
+    else if (t == TKEYWORD)
       {
         SCM v = STRING (x);
         while (a != cell_nil && v != STRING (CAAR (a)))
           a = CDR (a);
-        break;
       }
-      // case TSYMBOL:
-      // case TSPECIAL:
-    default:
-      while (a != cell_nil && x != CAAR (a))
-        a = CDR (a);
-    }
+  // else if (t == TSYMBOL)
+  // else if (t == TSPECIAL)
+  else
+    while (a != cell_nil && x != CAAR (a))
+      a = CDR (a);
   return a != cell_nil ? CAR (a) : cell_f;
 }
 
@@ -965,47 +1028,47 @@ eval_apply ()
   SCM x;
   int global_p;
   int macro_p;
+  int t;
+  int c;
 
  eval_apply:
-  switch (r3)
-    {
-    case cell_vm_evlis: goto evlis;
-    case cell_vm_evlis2: goto evlis2;
-    case cell_vm_evlis3: goto evlis3;
-    case cell_vm_apply: goto apply;
-    case cell_vm_apply2: goto apply2;
-    case cell_vm_eval: goto eval;
-    case cell_vm_eval_pmatch_car: goto eval_pmatch_car;
-    case cell_vm_eval_pmatch_cdr: goto eval_pmatch_cdr;
-    case cell_vm_eval_define: goto eval_define;
-    case cell_vm_eval_set_x: goto eval_set_x;
-    case cell_vm_eval_macro_expand_eval: goto eval_macro_expand_eval;
-    case cell_vm_eval_macro_expand_expand: goto eval_macro_expand_expand;
-    case cell_vm_eval_check_func: goto eval_check_func;
-    case cell_vm_eval2: goto eval2;
-    case cell_vm_macro_expand: goto macro_expand;
-    case cell_vm_macro_expand_define: goto macro_expand_define;
-    case cell_vm_macro_expand_define_macro: goto macro_expand_define_macro;
-    case cell_vm_macro_expand_lambda: goto macro_expand_lambda;
-    case cell_vm_macro_expand_set_x: goto macro_expand_set_x;
-    case cell_vm_macro_expand_car: goto macro_expand_car;
-    case cell_vm_macro_expand_cdr: goto macro_expand_cdr;
-    case cell_vm_begin: goto begin;
-    case cell_vm_begin_eval: goto begin_eval;
-    case cell_vm_begin_primitive_load: goto begin_primitive_load;
-    case cell_vm_begin_expand: goto begin_expand;
-    case cell_vm_begin_expand_eval: goto begin_expand_eval;
-    case cell_vm_begin_expand_macro: goto begin_expand_macro;
-    case cell_vm_begin_expand_primitive_load: goto begin_expand_primitive_load;
-    case cell_vm_if: goto vm_if;
-    case cell_vm_if_expr: goto if_expr;
-    case cell_vm_call_with_current_continuation2: goto call_with_current_continuation2;
-    case cell_vm_call_with_values2: goto call_with_values2;
-    case cell_vm_return: goto vm_return;
-    case cell_unspecified: return r1;
-    default:
-      assert (0);
-    }
+  if (r3 == cell_vm_evlis) goto evlis;
+  else if (r3 == cell_vm_evlis2) goto evlis2;
+  else if (r3 == cell_vm_evlis3) goto evlis3;
+  else if (r3 == cell_vm_apply) goto apply;
+  else if (r3 == cell_vm_apply2) goto apply2;
+  else if (r3 == cell_vm_eval) goto eval;
+  else if (r3 == cell_vm_eval_pmatch_car) goto eval_pmatch_car;
+  else if (r3 == cell_vm_eval_pmatch_cdr) goto eval_pmatch_cdr;
+  else if (r3 == cell_vm_eval_define) goto eval_define;
+  else if (r3 == cell_vm_eval_set_x) goto eval_set_x;
+  else if (r3 == cell_vm_eval_macro_expand_eval) goto eval_macro_expand_eval;
+  else if (r3 == cell_vm_eval_macro_expand_expand) goto eval_macro_expand_expand;
+  else if (r3 == cell_vm_eval_check_func) goto eval_check_func;
+  else if (r3 == cell_vm_eval2) goto eval2;
+  else if (r3 == cell_vm_macro_expand) goto macro_expand;
+  else if (r3 == cell_vm_macro_expand_define) goto macro_expand_define;
+  else if (r3 == cell_vm_macro_expand_define_macro) goto macro_expand_define_macro;
+  else if (r3 == cell_vm_macro_expand_lambda) goto macro_expand_lambda;
+  else if (r3 == cell_vm_macro_expand_set_x) goto macro_expand_set_x;
+  else if (r3 == cell_vm_macro_expand_car) goto macro_expand_car;
+  else if (r3 == cell_vm_macro_expand_cdr) goto macro_expand_cdr;
+  else if (r3 == cell_vm_begin) goto begin;
+  else if (r3 == cell_vm_begin_eval) goto begin_eval;
+  else if (r3 == cell_vm_begin_primitive_load) goto begin_primitive_load;
+  else if (r3 == cell_vm_begin_expand) goto begin_expand;
+  else if (r3 == cell_vm_begin_expand_eval) goto begin_expand_eval;
+  else if (r3 == cell_vm_begin_expand_macro) goto begin_expand_macro;
+  else if (r3 == cell_vm_begin_expand_primitive_load) goto begin_expand_primitive_load;
+  else if (r3 == cell_vm_if) goto vm_if;
+  else if (r3 == cell_vm_if_expr) goto if_expr;
+  else if (r3 == cell_vm_call_with_current_continuation2) goto call_with_current_continuation2;
+  else if (r3 == cell_vm_call_with_values2) goto call_with_values2;
+  else if (r3 == cell_vm_return) goto vm_return;
+  else if (r3 == cell_unspecified) return r1;
+  else
+    error (cell_symbol_system_error,
+           MAKE_STRING (cstring_to_list ("eval/apply unknown continuation")));
 
  evlis:
   if (r1 == cell_nil)
@@ -1022,92 +1085,85 @@ eval_apply ()
   goto vm_return;
 
  apply:
-  switch (TYPE (CAR (r1)))
+  t = TYPE (CAR (r1));
+  if (t == TFUNCTION)
     {
-    case TFUNCTION:
-      {
-        check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
-        r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
-        goto vm_return;
-      }
-    case TCLOSURE:
-      {
-        cl = CLOSURE (CAR (r1));
-        body = CDDR (cl);
-        formals = CADR (cl);
-        args = CDR (r1);
-        aa = CDAR (cl);
-        aa = CDR (aa);
-        check_formals (CAR (r1), formals, CDR (r1));
-        p = pairlis (formals, args, aa);
-        call_lambda (body, p, aa, r0);
-        goto begin;
-      }
-    case TCONTINUATION:
-      {
-        x = r1;
-        g_stack = CONTINUATION (CAR (r1));
-        gc_pop_frame ();
-        r1 = CADR (x);
-        goto eval_apply;
-      }
-    case TSPECIAL:
-      {
-        switch (CAR (r1))
-          {
-          case cell_vm_apply:
-            {
-              push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
-              goto apply;
-            }
-          case cell_vm_eval:
-            {
-              push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
-              goto eval;
-            }
-          case cell_vm_begin_expand:
-            {
-              push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
-              goto begin_expand;
-            }
-          case cell_call_with_current_continuation:
-            {
-              r1 = CDR (r1);
-              goto call_with_current_continuation;
-            }
-          default: check_apply (cell_f, CAR (r1));
-          }
-      }
-    case TSYMBOL:
-      {
-        if (CAR (r1) == cell_symbol_call_with_values)
-          {
-            r1 = CDR (r1);
-            goto call_with_values;
-          }
-        if (CAR (r1) == cell_symbol_current_module)
-          {
-            r1 = r0;
-            goto vm_return;
-          }
-        break;
-      }
-    case TPAIR:
-      {
-        switch (CAAR (r1))
-          {
-          case cell_symbol_lambda:
-            {
-              formals = CADR (CAR (r1));
-              args = CDR (r1);
-              body = CDDR (CAR (r1));
-              p = pairlis (formals, CDR (r1), r0);
-              check_formals (r1, formals, args);
-              call_lambda (body, p, p, r0);
-              goto begin;
-            }
-          }
-      }
+      check_formals (CAR (r1), MAKE_NUMBER (FUNCTION (CAR (r1)).arity), CDR (r1));
+      r1 = call (CAR (r1), CDR (r1)); /// FIXME: move into eval_apply
+      goto vm_return;
+    }
+  else if (t == TCLOSURE)
+    {
+      cl = CLOSURE (CAR (r1));
+      body = CDDR (cl);
+      formals = CADR (cl);
+      args = CDR (r1);
+      aa = CDAR (cl);
+      aa = CDR (aa);
+      check_formals (CAR (r1), formals, CDR (r1));
+      p = pairlis (formals, args, aa);
+      call_lambda (body, p, aa, r0);
+      goto begin;
+    }
+  else if (t == TCONTINUATION)
+    {
+      x = r1;
+      g_stack = CONTINUATION (CAR (r1));
+      gc_pop_frame ();
+      r1 = CADR (x);
+      goto eval_apply;
+    }
+  else if (t == TSPECIAL)
+    {
+      c = CAR (r1);
+      if (c == cell_vm_apply)
+        {
+          push_cc (cons (CADR (r1), CADDR (r1)), r1, r0, cell_vm_return);
+          goto apply;
+        }
+      else if (c ==  cell_vm_eval)
+        {
+          push_cc (CADR (r1), r1, CADDR (r1), cell_vm_return);
+          goto eval;
+        }
+      else if (c ==  cell_vm_begin_expand)
+        {
+          push_cc (cons (CADR (r1), cell_nil), r1, CADDR (r1), cell_vm_return);
+          goto begin_expand;
+        }
+      else if (c ==  cell_call_with_current_continuation)
+        {
+          r1 = CDR (r1);
+          goto call_with_current_continuation;
+        }
+      else
+        check_apply (cell_f, CAR (r1));
+    }
+  else if (t == TSYMBOL)
+    {
+      if (CAR (r1) == cell_symbol_call_with_values)
+        {
+          r1 = CDR (r1);
+          goto call_with_values;
+        }
+      if (CAR (r1) == cell_symbol_current_module)
+        {
+          r1 = r0;
+          goto vm_return;
+        }
+    }
+  else if (t == TPAIR)
+    {
+      if (CAAR (r1) == cell_symbol_lambda)
+        {
+          formals = CADR (CAR (r1));
+          args = CDR (r1);
+          body = CDDR (CAR (r1));
+          p = pairlis (formals, CDR (r1), r0);
+          check_formals (r1, formals, args);
+          call_lambda (body, p, p, r0);
+          goto begin;
+        }
     }
   push_cc (CAR (r1), r1, r0, cell_vm_apply2);
   goto eval;
@@ -1117,183 +1173,178 @@ eval_apply ()
   goto apply;
 
  eval:
-  switch (TYPE (r1))
+  t = TYPE (r1);
+  if (t == TPAIR)
     {
-    case TPAIR:
-      {
-        switch (CAR (r1))
-          {
-          case cell_symbol_pmatch_car:
-            {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
-              goto eval;
-            eval_pmatch_car:
-              x = r1;
-              gc_pop_frame ();
-              r1 = CAR (x);
-              goto eval_apply;
-            }
-          case cell_symbol_pmatch_cdr:
-            {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
-              goto eval;
-            eval_pmatch_cdr:
-              x = r1;
-              gc_pop_frame ();
-              r1 = CDR (x);
-              goto eval_apply;
-            }
-          case cell_symbol_quote:
-            {
-              x = r1;
-              gc_pop_frame ();
-              r1 = CADR (x);
-              goto eval_apply;
-            }
-          case cell_symbol_begin:
-            goto begin;
-          case cell_symbol_lambda:
-            {
-              r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
-              goto vm_return;
-            }
-          case cell_symbol_if:
-            {
-              r1=CDR (r1);
-              goto vm_if;
-            }
-          case cell_symbol_set_x:
-            {
-              push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
-              goto eval;
-            eval_set_x:
-              r1 = set_env_x (CADR (r2), r1, r0);
-              goto vm_return;
-            }
-          case cell_vm_macro_expand:
-            {
-              push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
-              goto eval;
-            eval_macro_expand_eval:
-              push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
-              goto macro_expand;
-            eval_macro_expand_expand:
-              goto vm_return;
-            }
-          default:
+      c = CAR (r1);
+      if (c ==  cell_symbol_pmatch_car)
+        {
+          push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_car);
+          goto eval;
+        eval_pmatch_car:
+          x = r1;
+          gc_pop_frame ();
+          r1 = CAR (x);
+          goto eval_apply;
+        }
+      else if (c ==  cell_symbol_pmatch_cdr)
+        {
+          push_cc (CADR (r1), r1, r0, cell_vm_eval_pmatch_cdr);
+          goto eval;
+        eval_pmatch_cdr:
+          x = r1;
+          gc_pop_frame ();
+          r1 = CDR (x);
+          goto eval_apply;
+        }
+      else if (c ==  cell_symbol_quote)
+        {
+          x = r1;
+          gc_pop_frame ();
+          r1 = CADR (x);
+          goto eval_apply;
+        }
+      else if (c ==  cell_symbol_begin)
+        goto begin;
+      else if (c ==  cell_symbol_lambda)
+        {
+          r1 = make_closure_ (CADR (r1), CDDR (r1), r0);
+          goto vm_return;
+        }
+      else if (c ==  cell_symbol_if)
+        {
+          r1=CDR (r1);
+          goto vm_if;
+        }
+      else if (c ==  cell_symbol_set_x)
+        {
+          push_cc (CAR (CDDR (r1)), r1, r0, cell_vm_eval_set_x);
+          goto eval;
+        eval_set_x:
+          r1 = set_env_x (CADR (r2), r1, r0);
+          goto vm_return;
+        }
+      else if (c == cell_vm_macro_expand)
+        {
+          push_cc (CADR (r1), r1, r0, cell_vm_eval_macro_expand_eval);
+          goto eval;
+        eval_macro_expand_eval:
+          push_cc (r1, r2, r0, cell_vm_eval_macro_expand_expand);
+          goto macro_expand;
+        eval_macro_expand_expand:
+          goto vm_return;
+        }
+      else
+        {
+          if (TYPE (r1) == TPAIR
+              && (CAR (r1) == cell_symbol_define
+                  || CAR (r1) == cell_symbol_define_macro))
             {
-              if (TYPE (r1) == TPAIR
-                  && (CAR (r1) == cell_symbol_define
-                      || CAR (r1) == cell_symbol_define_macro))
+              global_p = CAAR (r0) != cell_closure;
+              macro_p = CAR (r1) == cell_symbol_define_macro;
+              if (global_p)
                 {
-                  global_p = CAAR (r0) != cell_closure;
-                  macro_p = CAR (r1) == cell_symbol_define_macro;
-                  if (global_p)
-                    {
-                      name = CADR (r1);
-                      if (TYPE (CADR (r1)) == TPAIR)
-                        name = CAR (name);
-                      if (macro_p)
-                        {
-                          entry = assq (name, g_macros);
-                          if (entry == cell_f)
-                            {
-                              entry = cons (name, cell_f);
-                              g_macros = cons (entry, g_macros);
-                            }
-                        }
-                      else
-                        {
-                          entry = assq (name, r0);
-                          if (entry == cell_f)
-                            {
-                              entry = cons (name, cell_f);
-                              aa = cons (entry, cell_nil);
-                              set_cdr_x (aa, cdr (r0));
-                              set_cdr_x (r0, aa);
-                            }
-                        }
-                    }
-                  r2 = r1;
-                  if (TYPE (CADR (r1)) != TPAIR)
-                    {
-                      push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
-                      goto eval;
-                    }
-                  else
-                    {
-                      p = pairlis (CADR (r1), CADR (r1), r0);
-                      formals = CDR (CADR (r1));
-                      body = CDDR (r1);
-
-                      if (macro_p || global_p)
-                        expand_variable (body, formals);
-                      r1 = cons (cell_symbol_lambda, cons (formals, body));
-                      push_cc (r1, r2, p, cell_vm_eval_define);
-                      goto eval;
-                    }
-                eval_define:;
-                  name = CADR (r2);
-                  if (TYPE (CADR (r2)) == TPAIR)
+                  name = CADR (r1);
+                  if (TYPE (CADR (r1)) == TPAIR)
                     name = CAR (name);
                   if (macro_p)
                     {
                       entry = assq (name, g_macros);
-                      r1 = MAKE_MACRO (name, r1);
-                      set_cdr_x (entry, r1);
-                    }
-                  else if (global_p)
-                    {
-                      entry = assq (name, r0);
-                      set_cdr_x (entry, r1);
+                      if (entry == cell_f)
+                        {
+                          entry = cons (name, cell_f);
+                          g_macros = cons (entry, g_macros);
+                        }
                     }
                   else
                     {
-                      entry = cons (name, r1);
-                      aa = cons (entry, cell_nil);
-                      set_cdr_x (aa, cdr (r0));
-                      set_cdr_x (r0, aa);
-                      cl = assq (cell_closure, r0);
-                      set_cdr_x (cl, aa);
+                      entry = assq (name, r0);
+                      if (entry == cell_f)
+                        {
+                          entry = cons (name, cell_f);
+                          aa = cons (entry, cell_nil);
+                          set_cdr_x (aa, cdr (r0));
+                          set_cdr_x (r0, aa);
+                        }
                     }
-                  r1 = cell_unspecified;
-                  goto vm_return;
                 }
-              push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
-              gc_check ();
-              goto eval;
-            eval_check_func:
-              push_cc (CDR (r2), r2, r0, cell_vm_eval2);
-              goto evlis;
-            eval2:
-              r1 = cons (CAR (r2), r1);
-              goto apply;
+              r2 = r1;
+              if (TYPE (CADR (r1)) != TPAIR)
+                {
+                  push_cc (CAR (CDDR (r1)), r2, cons (cons (CADR (r1), CADR (r1)), r0), cell_vm_eval_define);
+                  goto eval;
+                }
+              else
+                {
+                  p = pairlis (CADR (r1), CADR (r1), r0);
+                  formals = CDR (CADR (r1));
+                  body = CDDR (r1);
+
+                  if (macro_p || global_p)
+                    expand_variable (body, formals);
+                  r1 = cons (cell_symbol_lambda, cons (formals, body));
+                  push_cc (r1, r2, p, cell_vm_eval_define);
+                  goto eval;
+                }
+            eval_define:;
+              name = CADR (r2);
+              if (TYPE (CADR (r2)) == TPAIR)
+                name = CAR (name);
+              if (macro_p)
+                {
+                  entry = assq (name, g_macros);
+                  r1 = MAKE_MACRO (name, r1);
+                  set_cdr_x (entry, r1);
+                }
+              else if (global_p)
+                {
+                  entry = assq (name, r0);
+                  set_cdr_x (entry, r1);
+                }
+              else
+                {
+                  entry = cons (name, r1);
+                  aa = cons (entry, cell_nil);
+                  set_cdr_x (aa, cdr (r0));
+                  set_cdr_x (r0, aa);
+                  cl = assq (cell_closure, r0);
+                  set_cdr_x (cl, aa);
+                }
+              r1 = cell_unspecified;
+              goto vm_return;
             }
-          }
-      }
-    case TSYMBOL:
-      {
-        if (r1 == cell_symbol_current_module)
-          goto vm_return;
-        if (r1 == cell_symbol_begin) // FIXME
-          {
-            r1 = cell_begin;
-            goto vm_return;
-          }
-        r1 = assert_defined (r1, assq_ref_env (r1, r0));
-        goto vm_return;
-      }
-    case TVARIABLE:
-      {
-        r1 = CDR (VARIABLE (r1));
+          push_cc (CAR (r1), r1, r0, cell_vm_eval_check_func);
+          gc_check ();
+          goto eval;
+        eval_check_func:
+          push_cc (CDR (r2), r2, r0, cell_vm_eval2);
+          goto evlis;
+        eval2:
+          r1 = cons (CAR (r2), r1);
+          goto apply;
+        }
+    }
+  else if (t == TSYMBOL)
+    {
+      if (r1 == cell_symbol_current_module)
         goto vm_return;
-      }
-    case TBROKEN_HEART:
-      {
-        error (cell_symbol_system_error,  r1);
-      }
-    default: goto vm_return;
+      if (r1 == cell_symbol_begin) // FIXME
+        {
+          r1 = cell_begin;
+          goto vm_return;
+        }
+      r1 = assert_defined (r1, assq_ref_env (r1, r0));
+      goto vm_return;
+    }
+  else if (t == TVARIABLE)
+    {
+      r1 = CDR (VARIABLE (r1));
+      goto vm_return;
     }
+  else if (t == TBROKEN_HEART)
+    error (cell_symbol_system_error,  r1);
+  else
+    goto vm_return;
 
  macro_expand:
   {