Back to index

plt-scheme  4.2.1
makeadder3m.c
Go to the documentation of this file.
00001 /* 
00002    The same as makeaddr.c, but revised and annotated so that it works
00003    with 3m without using --xform. All non-3m comments have been
00004    deleted (to better highlight the 3m parts).
00005 */
00006 
00007 #include "escheme.h"
00008 
00009 static Scheme_Object *sch_inner(void *closure_data, int argc, Scheme_Object **argv)
00010 {
00011   Scheme_Object *n = (Scheme_Object *)closure_data;
00012   Scheme_Object *plus, *plus_sym, *result;
00013   Scheme_Env *env;
00014   Scheme_Object *a[2];
00015   /* Declare registration space. The number 6 comes from the
00016      MZ_GC_VAR... declarations (i.e., if we add or remove
00017      some, the number changes */
00018   MZ_GC_DECL_REG(6);
00019 
00020   MZ_GC_ARRAY_VAR_IN_REG(0, a, 2); /* takes 3 slots */
00021   MZ_GC_VAR_IN_REG(3, argv);
00022   MZ_GC_VAR_IN_REG(4, n);
00023   MZ_GC_VAR_IN_REG(5, plus_sym);
00024   MZ_GC_REG();
00025 
00026   /* Note that we've pulled out nested calls and assigned
00027      the results to explicitly declared variables. Even though
00028      `env' is not help across an allocating function call,
00029      we need to lift out the call to scheme_get_env(), otherwise
00030      plus_sym's value might get pushed on the stack in anticipation
00031      of the function call, and the corresponding object might
00032      move. As written, plus_sym's value is not set up for the
00033      call until after scheme_get_env() returns. */
00034   plus_sym = scheme_intern_symbol("+");
00035   env = scheme_get_env(NULL);
00036   plus = scheme_lookup_global(plus_sym, env);
00037 
00038   a[0] = n;
00039   a[1] = argv[0]; /* m */
00040   result = _scheme_apply(plus, 2, a); 
00041   
00042   /* The following unregister can't go before _scheme_apply,
00043      because `a' is passed in as a stack-allocated array.
00044      If `a' were heap-allocated, instead, MZ_GC_UNREG()
00045      could go before the call to _scheme_apply. */
00046   MZ_GC_UNREG();
00047 
00048   return result;
00049 
00050 }
00051 
00052 static Scheme_Object *sch_make_adder(int argc, Scheme_Object **argv)
00053 {
00054   return scheme_make_closed_prim_w_arity(sch_inner,
00055                                     argv[0],
00056                                     "adder",
00057                                     1, 1);
00058 }
00059 
00060 Scheme_Object *scheme_reload(Scheme_Env *env)
00061 {
00062   Scheme_Object *p;
00063   MZ_GC_DECL_REG(1);
00064   MZ_GC_VAR_IN_REG(0, env);
00065   
00066   MZ_GC_REG();
00067 
00068   p = scheme_make_prim_w_arity(sch_make_adder,
00069                             "make-adder", 
00070                             1, 1);
00071 
00072   scheme_add_global("make-adder", p, env);
00073 
00074   MZ_GC_UNREG();
00075 
00076   return scheme_void;
00077 }
00078 
00079 Scheme_Object *scheme_initialize(Scheme_Env *env)
00080 {
00081   /* First load is same as every load: */
00082   return scheme_reload(env);
00083 }
00084 
00085 Scheme_Object *scheme_module_name()
00086 {
00087   /* This extension doesn't define a module: */
00088   return scheme_false;
00089 }