#line 1 "/build/ecl/src/ecl-26.3.27/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) == ECL_SYM("SI::SYMBOL-MACRO",1184))
        return CADDR(record);
      return ECL_NIL;
    }
  }
  return si_get_sysprop(name, ECL_SYM("SI::SYMBOL-MACRO",1184));
}

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 == ECL_SYM("SI::MACRO",1113))
          return CADDR(record);
        if (tag == ECL_SYM("FUNCTION",398))
          return ECL_NIL;
      }
    }
  }
  if (type & ecl_stp_macro) {
    return name->symbol.macfun;
  } else {
    return ECL_NIL;
  }
}

#line 81
cl_object cl_macro_function(cl_narg narg, cl_object sym, ...)
{
#line 81

#line 83
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 83
	cl_object env;
#line 83
	va_list ARGS;
	va_start(ARGS, sym);
#line 83
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(520));
#line 83
	if (narg > 1) {
#line 83
		env = va_arg(ARGS,cl_object);
#line 83
	} else {
#line 83
		env = ECL_NIL;
#line 83
	}
#line 83
  {
#line 83
	#line 83
	cl_object __value0 = (search_macro_function(sym, env));
#line 83
	the_env->nvalues = 1;
#line 83
	the_env->values[0] = __value0;
#line 83
	va_end(ARGS);
#line 83
	return __value0;
#line 83
}
;
}

/*
  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.
*/

#line 92
cl_object cl_macroexpand_1(cl_narg narg, cl_object form, ...)
{
#line 92

  cl_object exp_fun = ECL_NIL;
#line 95
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 95
	cl_object env;
#line 95
	va_list ARGS;
	va_start(ARGS, form);
#line 95
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(522));
#line 95
	if (narg > 1) {
#line 95
		env = va_arg(ARGS,cl_object);
#line 95
	} else {
#line 95
		env = ECL_NIL;
#line 95
	}
#line 95
  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, ECL_SYM("*MACROEXPAND-HOOK*",42));
    if (hook == ECL_SYM("FUNCALL",396))
      form = _ecl_funcall3(exp_fun, form, env);
    else
      form = _ecl_funcall4(hook, exp_fun, form, env);
  }
  {
#line 110
	#line 110
	cl_object __value0 = form;
#line 110
	cl_object __value1 = exp_fun;
#line 110
	the_env->nvalues = 2;
#line 110
	the_env->values[1] = __value1;
#line 110
	the_env->values[0] = __value0;
#line 110
	va_end(ARGS);
#line 110
	return __value0;
#line 110
}
;
}

/*
  Expands a form as many times as possible and returns the
  finally expanded form.
*/
#line 117
cl_object cl_macroexpand(cl_narg narg, cl_object form, ...)
{
#line 117

  cl_object done, old_form;
#line 120
#if defined(__clang__) || defined(__GNUC__)
	__attribute__((unused)) const cl_env_ptr the_env = ecl_process_env();
#else
	const cl_env_ptr the_env = ecl_process_env();
#endif
#line 120
	cl_object env;
#line 120
	va_list ARGS;
	va_start(ARGS, form);
#line 120
	if (ecl_unlikely(narg < 1|| narg > 2)) FEwrong_num_arguments(ecl_make_fixnum(521));
#line 120
	if (narg > 1) {
#line 120
		env = va_arg(ARGS,cl_object);
#line 120
	} else {
#line 120
		env = ECL_NIL;
#line 120
	}
#line 120
  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);
  {
#line 131
	#line 131
	cl_object __value0 = form;
#line 131
	cl_object __value1 = done;
#line 131
	the_env->nvalues = 2;
#line 131
	the_env->values[1] = __value1;
#line 131
	the_env->values[0] = __value0;
#line 131
	va_end(ARGS);
#line 131
	return __value0;
#line 131
}
;
}

static cl_object
or_macro(cl_object whole, cl_object env)
{
  cl_object output = ECL_NIL;
  whole = CDR(whole);
  if (Null(whole))        /* (OR) => NIL */
    {
#line 140
	const cl_env_ptr the_env = ecl_process_env();
#line 140
	#line 140
	cl_object __value0 = ECL_NIL;
#line 140
	the_env->nvalues = 1;
#line 140
	the_env->values[0] = __value0;
#line 140
	#line 140
	return __value0;
#line 140
}
;
  while (!Null(CDR(whole))) {
    output = CONS(CONS(CAR(whole), ECL_NIL), output);
    whole = CDR(whole);
  }
  if (Null(output)) {           /* (OR form1) => form1 */
    {
#line 146
	const cl_env_ptr the_env = ecl_process_env();
#line 146
	#line 146
	cl_object __value0 = CAR(whole);
#line 146
	the_env->nvalues = 1;
#line 146
	the_env->values[0] = __value0;
#line 146
	#line 146
	return __value0;
#line 146
}
;
  }
  /* (OR form1 ... formn forml) => (COND (form1) ... (formn) (t forml)) */
  output = CONS(cl_list(2, ECL_T, CAR(whole)), output);
  {
#line 150
	const cl_env_ptr the_env = ecl_process_env();
#line 150
	#line 150
	cl_object __value0 = CONS(ECL_SYM("COND",249), cl_nreverse(output));
#line 150
	the_env->nvalues = 1;
#line 150
	the_env->values[0] = __value0;
#line 150
	#line 150
	return __value0;
#line 150
}
;
}

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, ECL_SYM("IF",950), CAR(whole), expand_and(CDR(whole)));
}

static cl_object
and_macro(cl_object whole, cl_object env)
{
  {
#line 166
	const cl_env_ptr the_env = ecl_process_env();
#line 166
	#line 166
	cl_object __value0 = expand_and(CDR(whole));
#line 166
	the_env->nvalues = 1;
#line 166
	the_env->values[0] = __value0;
#line 166
	#line 166
	return __value0;
#line 166
}
;
}

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, ECL_SYM("IF",950), CAR(args), CONS(ECL_SYM("PROGN",674), CDR(args)));
}

void
init_macros(void)
{
  ECL_SET(ECL_SYM("*MACROEXPAND-HOOK*",42), ECL_SYM("FUNCALL",396));
  ecl_def_c_macro(ECL_SYM("OR",616), (cl_objectfn_fixed)or_macro, 2);
  ecl_def_c_macro(ECL_SYM("AND",89), (cl_objectfn_fixed)and_macro, 2);
  ecl_def_c_macro(ECL_SYM("WHEN",909), (cl_objectfn_fixed)when_macro, 2);
}
