ecl/src/c/macros.d

/* -*- Mode: C; c-basic-offset: 2; indent-tabs-mode: nil -*- */
/* vim: set filetype=c tabstop=2 shiftwidth=2 expandtab: */

/*
 * macros.d -- macros
 *
 * Copyright (c) 1984 Taiichi Yuasa and Masami Hagiya
 * Copyright (c) 1990 Giuseppe Attardi
 * Copyright (c) 2001 Juan Jose Garcia Ripoll
 *
 * See file 'LICENSE' for the copyright details.
 *
 */

#include <ecl/ecl.h>
#include <ecl/internal.h>

/******************************* ------- ******************************/
/*
 * The are two kinds of lisp environments. One of them is by the interpreter
 * when executing bytecodes and it contains local variable and function
 * definitions.
 *
 * The other environment is shared by the bytecodes compiler and by the C
 * compiler and it contains information for the compiler, including local
 * variable definitions, and local function and macro definitions. The
 * structure is as follows:
 *
 *      env -> ( var-list . fun-list )
 *      fun-list -> ( { definition | atomic-marker }* )
 *      definition -> ( macro-name SI::MACRO { extra-data }* )
 *                  | ( function-name FUNCTION { extra-data }* )
 *                  | ( a-symbol anything { extra-data }* )
 *      atomic-marker -> CB | LB
 *
 * The main difference between the bytecode and C compilers is on the extra
 * information. On the other hand, both environments are similar enough that
 * the functions MACROEXPAND-1, MACROEXPAND and MACRO-FUNCTION can find the
 * required information.
 */

static cl_object
search_symbol_macro(cl_object name, cl_object env)
{
  for (env = CAR(env); env != ECL_NIL; env = CDR(env)) {
    cl_object record = CAR(env);
    if (CONSP(record) && CAR(record) == name) {
      if (CADR(record) == @'si::symbol-macro')
        return CADDR(record);
      return ECL_NIL;
    }
  }
  return si_get_sysprop(name, @'si::symbol-macro');
}

static cl_object
search_macro_function(cl_object name, cl_object env)
{
  int type = ecl_symbol_type(name);
  if (env != ECL_NIL) {
    /* When the environment has been produced by the compiler, there might be
       atoms/symbols signaling function and unwind-protect boundaries. */
    while (!Null(env = CDR(env))) {
      cl_object record = CAR(env);
      if (CONSP(record) && CAR(record) == name) {
        cl_object tag = CADR(record);
        if (tag == @'si::macro')
          return CADDR(record);
        if (tag == @'function')
          return ECL_NIL;
      }
    }
  }
  if (type & ecl_stp_macro) {
    return name->symbol.macfun;
  } else {
    return ECL_NIL;
  }
}

@(defun macro_function (sym &optional env)
@
  @(return (search_macro_function(sym, env)));
@)

/*
  Analyze a form and expand it once if it is a macro form.
  VALUES(0) contains either the expansion or the original form.
  VALUES(1) is true when there was a macroexpansion.
*/

@(defun macroexpand_1 (form &optional (env ECL_NIL))
  cl_object exp_fun = ECL_NIL;
@
  if (ECL_ATOM(form)) {
    if (ECL_SYMBOLP(form))
      exp_fun = search_symbol_macro(form, env);
  } else {
    cl_object head = CAR(form);
    if (ECL_SYMBOLP(head))
      exp_fun = search_macro_function(head, env);
  }
  if (!Null(exp_fun)) {
    cl_object hook = ecl_cmp_symbol_value(the_env, @'*macroexpand-hook*');
    if (hook == @'funcall')
      form = _ecl_funcall3(exp_fun, form, env);
    else
      form = _ecl_funcall4(hook, exp_fun, form, env);
  }
  @(return form exp_fun);
@)

/*
  Expands a form as many times as possible and returns the
  finally expanded form.
*/
@(defun macroexpand (form &optional env)
  cl_object done, old_form;
@
  done = ECL_NIL;
  do {
    form = cl_macroexpand_1(2, old_form = form, env);
    if (ecl_nth_value(the_env, 1) == ECL_NIL) {
      break;
    } else if (old_form == form) {
      FEerror("Infinite loop when expanding macro form ~A", 1, old_form);
    } else {
      done = ECL_T;
    }
  } while (1);
  @(return form done);
@)

static cl_object
or_macro(cl_object whole, cl_object env)
{
  cl_object output = ECL_NIL;
  whole = CDR(whole);
  if (Null(whole))        /* (OR) => NIL */
    @(return ECL_NIL);
  while (!Null(CDR(whole))) {
    output = CONS(CONS(CAR(whole), ECL_NIL), output);
    whole = CDR(whole);
  }
  if (Null(output)) {           /* (OR form1) => form1 */
    @(return CAR(whole));
  }
  /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */
  output = CONS(cl_list(2, ECL_T, CAR(whole)), output);
  @(return CONS(@'cond', cl_nreverse(output)));
}

static cl_object
expand_and(cl_object whole)
{
  if (Null(whole))
    return ECL_T;
  if (Null(CDR(whole)))
    return CAR(whole);
  return cl_list(3, @'if', CAR(whole), expand_and(CDR(whole)));
}

static cl_object
and_macro(cl_object whole, cl_object env)
{
  @(return expand_and(CDR(whole)));
}

static cl_object
when_macro(cl_object whole, cl_object env)
{
  cl_object args = CDR(whole);
  if (ecl_unlikely(ecl_endp(args)))
    FEprogram_error("Syntax error: ~S.", 1, whole);
  return cl_list(3, @'if', CAR(args), CONS(@'progn', CDR(args)));
}

void
init_macros(void)
{
  ECL_SET(@'*macroexpand-hook*', @'funcall');
  ecl_def_c_macro(@'or', (cl_objectfn_fixed)or_macro, 2);
  ecl_def_c_macro(@'and', (cl_objectfn_fixed)and_macro, 2);
  ecl_def_c_macro(@'when', (cl_objectfn_fixed)when_macro, 2);
}