guile's OCCC contributions :>

[Jost Boekemeier <jostobfe@calvados.zrz.TU-Berlin.DE>]

The following code snippets come from the guile evaluator and from
the SCM evaluator and do both the same.


scm macros:
--------------------------------------------------
#define ATOMP(x) (5==(5 & (int)CAR(x)))
#define EVALCELLCAR(x) (ATOMP(CAR(x))?evalatomcar(x):ceval_1(CAR(x)))
#define EVALIMP(x) (ILOCP(x)?*ilookup(x):x)
#define EVALCAR(x) (NCELLP(CAR(x))?(IMP(CAR(x))?EVALIMP(CAR(x)):\
					I_VAL(CAR(x))):EVALCELLCAR(x))
long tc16_macro;		/* Type code for macros */
#define MACROP(x) (tc16_macro==TYP16(x))
--------------------------------------------------

versus

guile macros:
--------------------------------------------------
#define SCM_CEVAL scm_ceval
#define SIDEVAL(x, env) if SCM_NIMP(x) SCM_CEVAL((x), (env))

#define EVALCELLCAR(x, env) (SCM_SYMBOLP (SCM_CAR(x)) \
			     ? *scm_lookupcar(x, env, 0) \
			     : SCM_CEVAL(SCM_CAR(x), env))

#define EVALCAR(x, env) (SCM_NCELLP(SCM_CAR(x))\
			? (SCM_IMP(SCM_CAR(x)) \
			   ? SCM_EVALIM(SCM_CAR(x), env) \
			   : SCM_GLOC_VAL(SCM_CAR(x))) \
			: EVALCELLCAR(x, env))

[...]
#undef SCM_CEVAL
#define SCM_CEVAL scm_deval	/* Substitute all uses of scm_ceval */
#undef SCM_APPLY
#define SCM_APPLY scm_dapply
#undef PREP_APPLY
#define PREP_APPLY(p, l) \
{ ++debug.info; debug.info->a.proc = p; debug.info->a.args = l; }
#undef ENTER_APPLY
#define ENTER_APPLY \
{\
  SCM_SET_ARGSREADY (debug);\
  if (CHECK_APPLY && SCM_TRAPS_P)\
    if (SCM_APPLY_FRAME_P || (SCM_TRACE_P && PROCTRACEP (proc)))\
      {\
	SCM tmp, tail = SCM_TRACED_FRAME_P (debug) ? SCM_BOOL_T : SCM_BOOL_F;\
	SCM_SET_TRACED_FRAME (debug); \
	if (SCM_CHEAPTRAPS_P)\
	  {\
	    tmp = scm_make_debugobj (&debug);\
	    scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
 	  }\
	else\
	  {\
	    scm_make_cont (&tmp);\
	    if (!setjmp (SCM_JMPBUF (tmp)))\
	      scm_ithrow (scm_i_apply_frame, scm_cons2 (tmp, tail, SCM_EOL), 0);\
	  }\
      }\
}
#undef RETURN
#define RETURN(e) {proc = (e); goto exit;}
#ifdef STACK_CHECKING
#ifndef EVAL_STACK_CHECKING
#define EVAL_STACK_CHECKING
#endif
#endif

/* scm_ceval_ptr points to the currently selected evaluator.
 * *fixme*: Although efficiency is important here, this state variable
 * should probably not be a global.  It should be related to the
 * current repl.
 */

--------------------------------------------------


guile evaluator:
--------------------------------------------------
/* handle function calls */

    case scm_tcs_cons_gloc:
      proc = SCM_GLOC_VAL (SCM_CAR (x));
      if (proc == 0)
	/* This is a struct implanted in the code, not a gloc. */
	RETURN (x);
      SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef SCM_RECKLESS
#ifdef SCM_CAUTIOUS
      goto checkargs;
#endif
#endif
      break;

    case scm_tcs_cons_nimcar:
      if (SCM_SYMBOLP (SCM_CAR (x)))
	{
#ifdef USE_THREADS
	  t.lloc = scm_lookupcar1 (x, env, 0);  
	  if (t.lloc == NULL)
	    {
	      /* we have lost the race, start again. */
	      goto dispatch;
	    }
	  proc = *t.lloc;
#else
	  proc = *scm_lookupcar (x, env, 0);
#endif

	  if (SCM_IMP (proc))
	    {
	      unmemocar (x, env);
	      goto badfun;
	    }
	  if (scm_tc16_macro == SCM_TYP16 (proc))
	    {
	      unmemocar (x, env);

	    handle_a_macro:
#ifdef DEVAL
	      /* Set a flag during macro expansion so that macro
		 application frames can be deleted from the backtrace. */
	      SCM_SET_MACROEXP (debug);
#endif
	      t.arg1 = SCM_APPLY (SCM_CDR (proc), x,
				  scm_cons (env, scm_listofnull));

#ifdef DEVAL
	      SCM_CLEAR_MACROEXP (debug);
#endif
	      switch ((int) (SCM_CAR (proc) >> 16))
		{
		case 2:
		  if (scm_ilength (t.arg1) <= 0)
		    t.arg1 = scm_cons2 (SCM_IM_BEGIN, t.arg1, SCM_EOL);
#ifdef DEVAL
		  if (!SCM_CLOSUREP (SCM_CDR (proc)))
		    {

#if 0 /* Top-level defines doesn't very often occur in backtraces */
		      if (scm_m_define == SCM_SUBRF (SCM_CDR (proc)) && SCM_TOP_LEVEL_ENVP (env))
			/* Prevent memoizing result of define macro */
			{
			  debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
			  scm_set_source_properties_x (debug.info->e.exp,
						       scm_source_properties (x));
			}
#endif
		      SCM_DEFER_INTS;
		      SCM_SETCAR (x, SCM_CAR (t.arg1));
		      SCM_SETCDR (x, SCM_CDR (t.arg1));
		      SCM_ALLOW_INTS;
		      goto dispatch;
		    }
		  /* Prevent memoizing of debug info expression. */
		  debug.info->e.exp = scm_cons (SCM_CAR (x), SCM_CDR (x));
		  scm_set_source_properties_x (debug.info->e.exp,
					       scm_source_properties (x));
#endif
		  SCM_DEFER_INTS;
		  SCM_SETCAR (x, SCM_CAR (t.arg1));
		  SCM_SETCDR (x, SCM_CDR (t.arg1));
		  SCM_ALLOW_INTS;
		  goto loopnoap;
		case 1:
		  if (SCM_NIMP (x = t.arg1))
		    goto loopnoap;
		case 0:
		  RETURN (t.arg1);
		}
	    }
	}
      else
	proc = SCM_CEVAL (SCM_CAR (x), env);
      SCM_ASRTGO (SCM_NIMP (proc), badfun);
#ifndef SCM_RECKLESS
#ifdef SCM_CAUTIOUS
    checkargs:
#endif
      if (SCM_CLOSUREP (proc))
	{
	  arg2 = SCM_CAR (SCM_CODE (proc));
	  t.arg1 = SCM_CDR (x);
	  while (SCM_NIMP (arg2))
	    {
	      if (SCM_NCONSP (arg2))
		goto evapply;
	      if (SCM_IMP (t.arg1))
		goto umwrongnumargs;
	      arg2 = SCM_CDR (arg2);
	      t.arg1 = SCM_CDR (t.arg1);
	    }
	  if (SCM_NNULLP (t.arg1))
	    goto umwrongnumargs;
	}
      else if (scm_tc16_macro == SCM_TYP16 (proc))
	goto handle_a_macro;
#endif
    }


evapply:

/* on with 0 .. n args functions */
--------------------------------------------------

versus

scm evaluator:
--------------------------------------------------
/* handle function calls */

  case tcs_cons_gloc:
    proc = I_VAL(CAR(x));
    break;
  case tcs_cons_nimcar:
    if ATOMP(CAR(x)) {
#ifdef MEMOIZE_LOCALS
      x = macroexp1(x, !0);
      goto loop;
#else
      proc = *lookupcar(x, 0);
      if (NIMP(proc) && MACROP(proc)) {
	x = macroexp1(x, !0);
	goto loop;
      }
#endif
    }
    else proc = ceval_1(CAR(x));
    /* At this point proc is the evaluated procedure from the function
       position and x has the form which is being evaluated. */
  }
  ASRTGO(NIMP(proc), badfun);
  *scm_estk_ptr = scm_env; /* For error reporting at wrongnumargs. */
  if NULLP(CDR(x)) {
  evap0:
    ENV_MAY_POP(envpp, CLOSUREP(proc));
    ALLOW_INTS_EGC;
    switch TYP7(proc) { /* no arguments given */
    case tc7_subr_0:
      return SUBRF(proc)();

/* on with 0...n args functions */
--------------------------------------------------


guile lambda proc
--------------------------------------------------
SCM 
scm_m_lambda (xorig, env)
     SCM xorig;
     SCM env;
{
  SCM proc, x = SCM_CDR (xorig);
  if (scm_ilength (x) < 2)
    goto badforms;
  proc = SCM_CAR (x);
  if (SCM_NULLP (proc))
    goto memlambda;
  if (SCM_IMP (proc))
    goto badforms;
  if (SCM_SYMBOLP (proc))
    goto memlambda;
  if (SCM_NCONSP (proc))
    goto badforms;
  while (SCM_NIMP (proc))
    {
      if (SCM_NCONSP (proc))
	{
	  if (!SCM_SYMBOLP (proc))
	    goto badforms;
	  else
	    goto memlambda;
	}
      if (!(SCM_NIMP (SCM_CAR (proc)) && SCM_SYMBOLP (SCM_CAR (proc))))
	goto badforms;
      proc = SCM_CDR (proc);
    }
  if SCM_NNULLP
    (proc)
  badforms:scm_wta (xorig, scm_s_formals, "lambda");
memlambda:
  bodycheck (xorig, SCM_CDRLOC (x), "lambda");
  return scm_cons (SCM_IM_LAMBDA, SCM_CDR (xorig));
}
--------------------------------------------------

versus


SCM lambda proc
--------------------------------------------------
SCM m_lambda(xorig, env)
     SCM xorig, env;
{
  SCM x = CDR(xorig);
  int argc;
  ASSERT(ilength(x) > 1, xorig, s_formals, s_lambda);
  argc = varcheck(xorig, CAR(x), s_lambda, s_formals);
  if (argc > 3) argc = 3;
  return cons2(MAKISYMVAL(IM_LAMBDA, argc), CAR(x),
	       m_body(IM_LAMBDA, CDR(x), s_lambda));
}
--------------------------------------------------


And as a special contribution:

--------------------------------------------------
/* SECTION: This is the evaluator.  Like any real monster, it has
 * three heads.  This code is compiled twice.
 */
--------------------------------------------------


:)))))