Examples

The first example shows the simple implemantation of delay:

Scheme_Object *delay_syntax(Scheme_Object *form, Scheme_Env *env, 
                            Scheme_Compile_Info *rec)
/* This is the compiler */
{
  /* Check the form: */
  form = SCHEME_CDR(form);
  if (!SCHEME_PAIRP(form) || !SCHEME_NULLP(SCHEME_CDR(form)))
    scheme_signal_error("bad `delay' form");
  
  /* Compile the subexpression: */
  form = scheme_compile_expr(SCHEME_CAR(form), env, rec);

  /* Return a syntax compilation or link: */
  if (rec->can_optimize_constants)
    return scheme_make_syntax_link(delay_execute, form);
  else
    return scheme_make_syntax_compilation(delay_link, form);
}

Scheme_Object *delay_link(Scheme_Object *expr, Scheme_Env *env)
/* This is the linker */
{
  /* Linking is linking the sub-expression */
  return scheme_link_expr(expr, env);
}

Scheme_Object *delay_execute(Scheme_Object *expr, Scheme_Env *env)
/* This is the executor */
{
  /* Execution is making a promise: */
  return scheme_make_promise_compiled(expr, env);
}

Scheme_Object *delay_expand(Scheme_Object *form, Scheme_Env *env, 
                            int depth)
/* This is the expander */
{
  /* Expand the sub-expression and cons 'delay to the front: */
  return scheme_make_pair(SCHEME_CAR(form),
                          scheme_expand_list(SCHEME_CDR(form), env, depth));
}

Note that in delay_syntax, scheme_compile_expr performs all the work in filling in rec. This implementation delay is installed with the following two function calls:

  scheme_register_syntax_linker("delay", delay_link);
  scheme_add_global("delay", 
                    scheme_make_compiled_syntax(delay_syntax, 
                                                delay_expand),
                    global_env);

The definition of quote is even simpler:

Scheme_Object *quote_syntax(Scheme_Object *form, Scheme_Env *env, 
                            Scheme_Compile_Info *rec)
{
  Scheme_Object *v;

  SCHEME_ASSERT (SCHEME_PAIRP(SCHEME_CDR(form))
		 && SCHEME_NULLP(SCHEME_CDR(SCHEME_CDR(form))),
		 "quote: wrong number of args");

  /* Set compilation info required by the owning context: */
  rec->max_let_depth = 0;
  rec->can_return_closure = 0;
  rec->is_proc_closure = 0;

  v = SCHEME_CAR(SCHEME_CDR(form));

  if (rec->can_optimize_constants)
    return v;
  else
    return scheme_make_syntax_compilation(quote_link, v);
}

static Scheme_Object *quote_link (Scheme_Object *v, Scheme_Env *env)
{
  return v;
}

Scheme_Object *quote_expand(Scheme_Object *form, Scheme_Env *env, 
                            int depth)
{
  return form;
}

Note that quote has no executor -- there is essentially no run-time work for quote. The expander does nothing at all, because quote does not contain any sub-expressions which are evaluated. While quote_syntax does not use compilation information for its surrounding context, it must still fill in rec with returned information.

As a final example, imagine a syntactic form (with-window window body ...) that is used in a MzScheme interpreter that is embedded in (or extended with) a graphics system. with-window evaluates the expression window to get a window record, binds new local variables name, width, height, and drawing-context to the values of components of this window, and then evaluates body in the extended evironment.

This example covers all of the interesting aspects of syntax implementation, including compiling sub-expressions and creating a new Scheme type to hold compiled information.

/* Constant values: */
Scheme_Type with_win_data_type;
Scheme_Object *name_symbol, *width_symbol, *height_symbol, *dc_symbol;

/* Compiled info structure: */
typedef struct {
  Scheme_Type type;
  int allocate_frame;
  int start_frame_slot;
  int extra_frame_slots;
  Scheme_Object *win_expr, *body;
} With_Win_Data;

/* Compile a `with-window' expression */
Scheme_Object *with_win_syntax(Scheme_Object *form, Scheme_Env *env, 
                               Scheme_Compile_Info *rec)
{
  Scheme_Object *body, *win_expr;
  With_Win_Data *data;
  Scheme_Env *new_env;
  Scheme_Compile_Info subrecs[2];

  /* We really need form-checking here: */
  form = SCHEME_CDR(form);
  if (!SCHEME_PAIRP(form))
    scheme_signal_error("with-window: bad form");
  win_expr = SCHEME_CAR(form);
  body = SCHEME_CDR(form);

  data = (With_Win_Data *)scheme_malloc(sizeof(With_Win_Data));
  data->type = with_win_data_type;

  /* Initialize sub-compilation info; we have 2 sub-parts: */
  scheme_init_compile_recs(rec, subrecs, 2);

  /* Compile the expression */
  data->win_expr = scheme_compile_expr(win_expr, env, &subrecs[0]);

  if (rec->base_let_depth >= 0) {
    /* Someone else will allocate the environment frame at run-time: */
    data->allocate_frame = 0;
    data->start_frame_slot = rec->base_let_depth;

    /* Re-allocate last frame, making room for 4 more: */
    new_env = scheme_lengthen_compilation_frame(4, env);
  } else {
    /* We must allocate the environment frame: */
    data->allocate_frame = 1;
    data->start_frame_slot = 0;
    
    new_env = scheme_new_compilation_frame(4, 0);
    new_env = scheme_extend_env(new_env, env);
  }
  
  /* Add names for our locals: */
  scheme_add_compilation_binding(data->start_frame_slot, name_symbol, 
				 new_env);
  scheme_add_compilation_binding(data->start_frame_slot + 1, width_symbol, 
				 new_env);
  scheme_add_compilation_binding(data->start_frame_slot + 2, height_symbol, 
				 new_env);
  scheme_add_compilation_binding(data->start_frame_slot + 3, dc_symbol, 
				 new_env);

  /* Make an adjustment to the second sub-rec: account for 4 locals */
  subrecs[1].base_let_depth = data->start_frame_slot + 4;

  /* Compile the body: */
  data->body = scheme_compile_sequence(body, new_env, &subrecs[1]);

  /* Merge compilation information: */
  scheme_merge_compile_recs(rec, subrecs, 2);

  /* If we allocate, did sub-expressions ask for extra frame slots?: */
  if (data->allocate_frame)
    data->extra_frame_slots = rec->max_let_depth;

  if (!data->allocate_frame)
    /* We made a copy of env; propogate the settable flag: */
    scheme_frame_backinfo(new_env, env);

  /* Adjust outgoing info to account for 4 locals: */
  rec->max_let_depth += 4;

  /* Return compiled or compiled & linked, depending on 
     rec->can_optimize_constants */
  if (rec->can_optimize_constants)
    return scheme_make_syntax_link(with_win_execute, 
				   (Scheme_Object *)data);
  else
    return scheme_make_syntax_compilation(with_win_link, 
					  (Scheme_Object *)data);
}

/* Link a `with-window' expression */
Scheme_Object *with_win_link(Scheme_Object *cdata, Scheme_Env *env)
{
  With_Win_Data *data, *new_data;

  data = (With_Win_Data *)cdata;

  /* Allocate a linked copy */
  new_data = (With_Win_Data *)scheme_malloc(sizeof(With_Win_Data));
  new_data->type = with_win_data_type;

  /* Copy simple fields */
  new_data->allocate_frame = data->allocate_frame;
  new_data->start_frame_slot = data->start_frame_slot;
  new_data->extra_frame_slots = data->extra_frame_slots;

  /* Link compiled fields: */
  new_data->win_expr = scheme_link_expr(data->win_expr, env);
  new_data->body = scheme_link_expr(data->body, env);

  return scheme_make_syntax_link(with_win_execute,
				 (Scheme_Object *)new_data);
}

/* Execute a `with-window' expression */
Scheme_Object *with_win_execute(Scheme_Object *cdata, Scheme_Env *env)
{
  With_Win_Data *data;
  Scheme_Object *win;
 
  data = (With_Win_Data *)cdata;

  /* First, evaluate the initial expression to get a window: */
  win = scheme_eval_compiled(data->win_expr, env);

  /* Allocate a frame, if it was not done for us: */
  if (data->allocate_frame) {
    Scheme_Env *frame;

    /* Allocate a new the frame: */
    frame = scheme_new_frame(4 + data->extra_frame_slots);
    env = scheme_extend_env(frame, env);
  }

  /* Assume all the functions window_get_name, etc. are defined,
     taking a Scheme window and returning a scheme value */
  scheme_add_binding(data->start_frame_slot,
                     window_get_name(win), env);
  scheme_add_binding(data->start_frame_slot + 1,
                     window_get_height(win), env);
  scheme_add_binding(data->start_frame_slot + 2,
                     window_get_width(win), env);
  scheme_add_binding(data->start_frame_slot + 3,
                     window_get_dc(win), env);

  /* Evaluate the body to get the final value: */
  return scheme_tail_eval_expr(data->body, env);
}

Scheme_Object *with_win_expand(Scheme_Object *form, Scheme_Env *env, 
                               int depth)
{
  Scheme_Object *body, *win_expr;

  /* We really need form-checking here: */
  win_expr = SCHEME_CAR(SCHEME_CDR(form));
  body = SCHEME_CDR(SCHEME_CDR(form));

  /* Expand window expression: */
  win_expr = scheme_expand_expr(win_expr, env, depth);
  
  /* Don't worry about putting everything in the same frame for expansion: */
  env = scheme_add_compilation_frame(scheme_make_pair(name_symbol,
                           scheme_make_pair(width_symbol,
                             scheme_make_pair(height_symbol,
                               scheme_make_pair(dc_symbol, scheme_null)))),
                         env, 
                         0);

  /* Expand body: */
  body = scheme_expand_block(body, env, depth);

  return scheme_make_pair(SCHEME_CAR(form),
                          scheme_make_pair(win_expr, body));
}

Scheme_Object *write_with_wind_data(Scheme_Object *cdata)
/* Bundles compiled data: */
{
  With_Win_Data *data;
 
  data = (With_Win_Data *)cdata;

  return scheme_make_pair(data->allocate_frame ? scheme_true : scheme_false,
           scheme_make_pair(scheme_make_integer(data->start_frame_slot),
             scheme_make_pair(scheme_make_integer(data->extra_frame_slots),
               scheme_make_pair(data->win_expr, data->body))));
}

Scheme_Object *read_with_wind_data(Scheme_Object *form)
/* Unbundles compiled data: */
{
  With_Win_Data *data;
 
  data = (With_Win_Data *)scheme_malloc(sizeof(With_Win_Data));

  data->allocate_frame = !SCHEME_FALSEP(SCHEME_CAR(form));
  form = SCHEME_CDR(form);
  data->start_frame_slot = SCHEME_INT_VAL(SCHEME_CAR(form));
  form = SCHEME_CDR(form);
  data->extra_frame_slots = SCHEME_INT_VAL(SCHEME_CAR(form));
  form = SCHEME_CDR(form);
  data->win_expr = SCHEME_CAR(form);
  data->body = SCHEME_CDR(form);

  return (Scheme_Object *)data;
}

This syntax requires several intialization steps:

  with_win_data_type = scheme_make_type("<with-win-data>");

  name_symbol = scheme_intern_symbol("name");
  width_symbol = scheme_intern_symbol("width");
  height_symbol = scheme_intern_symbol("height");
  dc_symbol = scheme_intern_symbol("drawing-context");

  scheme_register_syntax_linker("withwin", with_win_link);
  scheme_add_global("with-window", 
                    scheme_make_compiled_syntax(with_win_syntax, 
                                                with_win_expand),
                    global_env);

  scheme_install_type_writer(with_win_data_type, write_with_wind_data);
  scheme_install_type_reader(with_win_data_type, read_with_wind_data);

  scheme_register_extension_global(&name_symbol, sizeof(Scheme_Object *));
  scheme_register_extension_global(&width_symbol, sizeof(Scheme_Object *));
  scheme_register_extension_global(&height_symbol, sizeof(Scheme_Object *));
  scheme_register_extension_global(&dc_symbol, sizeof(Scheme_Object *));

The elaborate frame-juggling that is performed by the compiler and executor allows nested let-like expressions to use a single allocated frame. The implementor of with-window could chose instead to always allocate a frame and not allocate extra slots for the sub-expressions; this would simply the syntax implementation considerably with potentially slower execution of the compiled code.