+/* Multi-language support */
+
+SCM scm_lisp_nil;
+SCM scm_lisp_t;
+
+SCM_SYNTAX (s_nil_cond, "nil-cond", scm_makmmacro, scm_m_nil_cond);
+
+SCM
+scm_m_nil_cond (SCM xorig, SCM env)
+{
+ int len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
+ scm_s_expression, "nil-cond");
+ return scm_cons (SCM_IM_NIL_COND, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_nil_ify, "nil-ify", scm_makmmacro, scm_m_nil_ify);
+
+SCM
+scm_m_nil_ify (SCM xorig, SCM env)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+ xorig, scm_s_expression, "nil-ify");
+ return scm_cons (SCM_IM_NIL_IFY, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_t_ify, "t-ify", scm_makmmacro, scm_m_t_ify);
+
+SCM
+scm_m_t_ify (SCM xorig, SCM env)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+ xorig, scm_s_expression, "t-ify");
+ return scm_cons (SCM_IM_T_IFY, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_0_cond, "0-cond", scm_makmmacro, scm_m_0_cond);
+
+SCM
+scm_m_0_cond (SCM xorig, SCM env)
+{
+ int len = scm_ilength (SCM_CDR (xorig));
+ SCM_ASSYNT (len >= 1 && (len & 1) == 1, xorig,
+ scm_s_expression, "0-cond");
+ return scm_cons (SCM_IM_0_COND, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_0_ify, "0-ify", scm_makmmacro, scm_m_0_ify);
+
+SCM
+scm_m_0_ify (SCM xorig, SCM env)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+ xorig, scm_s_expression, "0-ify");
+ return scm_cons (SCM_IM_0_IFY, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_1_ify, "1-ify", scm_makmmacro, scm_m_1_ify);
+
+SCM
+scm_m_1_ify (SCM xorig, SCM env)
+{
+ SCM_ASSYNT (scm_ilength (SCM_CDR (xorig)) == 1,
+ xorig, scm_s_expression, "1-ify");
+ return scm_cons (SCM_IM_1_IFY, SCM_CDR (xorig));
+}
+
+SCM_SYNTAX (s_atfop, "@fop", scm_makmmacro, scm_m_atfop);
+
+SCM
+scm_m_atfop (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig), vcell;
+ SCM_ASSYNT (scm_ilength (x) >= 1, xorig, scm_s_expression, "@fop");
+ vcell = scm_symbol_fref (SCM_CAR (x));
+ SCM_ASSYNT (SCM_CONSP (vcell), x,
+ "Symbol's function definition is void", NULL);
+ SCM_SETCAR (x, vcell + 1);
+ return x;
+}
+
+SCM_SYNTAX (s_atbind, "@bind", scm_makmmacro, scm_m_atbind);
+
+SCM
+scm_m_atbind (SCM xorig, SCM env)
+{
+ SCM x = SCM_CDR (xorig);
+ SCM_ASSYNT (scm_ilength (x) > 1, xorig, scm_s_expression, "@bind");
+
+ if (SCM_IMP (env))
+ env = SCM_BOOL_F;
+ else
+ {
+ while (SCM_NIMP (SCM_CDR (env)))
+ env = SCM_CDR (env);
+ env = SCM_CAR (env);
+ if (SCM_CONSP (env))
+ env = SCM_BOOL_F;
+ }
+
+ x = SCM_CAR (x);
+ while (SCM_NIMP (x))
+ {
+ SCM_SETCAR (x, scm_sym2vcell (SCM_CAR (x), env, SCM_BOOL_T) + 1);
+ x = SCM_CDR (x);
+ }
+ return scm_cons (SCM_IM_BIND, SCM_CDR (xorig));
+}
+
+SCM
+scm_m_expand_body (SCM xorig, SCM env)
+{
+ SCM form, x = SCM_CDR (xorig), defs = SCM_EOL;
+ char *what = SCM_ISYMCHARS (SCM_CAR (xorig)) + 2;
+
+ while (SCM_NIMP (x))
+ {
+ form = SCM_CAR (x);
+ if (SCM_IMP (form) || SCM_NCONSP (form))
+ break;
+ if (SCM_IMP (SCM_CAR (form)))
+ break;
+ if (!SCM_SYMBOLP (SCM_CAR (form)))
+ break;
+
+ form = scm_macroexp (scm_cons_source (form,
+ SCM_CAR (form),
+ SCM_CDR (form)),
+ env);
+
+ if (SCM_EQ_P (SCM_IM_DEFINE, SCM_CAR (form)))
+ {
+ defs = scm_cons (SCM_CDR (form), defs);
+ x = SCM_CDR(x);
+ }
+ else if (SCM_NIMP(defs))
+ {
+ break;
+ }
+ else if (SCM_EQ_P (SCM_IM_BEGIN, SCM_CAR (form)))
+ {
+ x = scm_append (scm_cons2 (SCM_CDR (form), SCM_CDR (x), SCM_EOL));
+ }
+ else
+ {
+ x = scm_cons (form, SCM_CDR(x));
+ break;
+ }
+ }
+
+ SCM_ASSYNT (SCM_NIMP (x), SCM_CDR (xorig), scm_s_body, what);
+ if (SCM_NIMP (defs))
+ {
+ x = scm_cons (scm_m_letrec1 (SCM_IM_LETREC,
+ SCM_IM_DEFINE,
+ scm_cons2 (scm_sym_define, defs, x),
+ env),
+ SCM_EOL);
+ }
+
+ SCM_DEFER_INTS;
+ SCM_SETCAR (xorig, SCM_CAR (x));
+ SCM_SETCDR (xorig, SCM_CDR (x));
+ SCM_ALLOW_INTS;
+
+ return xorig;
+}
+
+SCM
+scm_macroexp (SCM x, SCM env)
+{
+ SCM res, proc;
+
+ /* Don't bother to produce error messages here. We get them when we
+ eventually execute the code for real. */
+
+ macro_tail:
+ if (SCM_IMP (SCM_CAR (x)) || !SCM_SYMBOLP (SCM_CAR (x)))
+ return x;
+
+#ifdef USE_THREADS
+ {
+ SCM *proc_ptr = scm_lookupcar1 (x, env, 0);
+ if (proc_ptr == NULL)
+ {
+ /* We have lost the race. */
+ goto macro_tail;
+ }
+ proc = *proc_ptr;
+ }
+#else
+ proc = *scm_lookupcar (x, env, 0);
+#endif
+
+ /* Only handle memoizing macros. `Acros' and `macros' are really
+ special forms and should not be evaluated here. */
+
+ if (SCM_IMP (proc)
+ || scm_tc16_macro != SCM_TYP16 (proc)
+ || (int) (SCM_UNPACK_CAR (proc) >> 16) != 2)
+ return x;
+
+ unmemocar (x, env);
+ res = scm_apply (SCM_CDR (proc), x, scm_cons (env, scm_listofnull));
+
+ if (scm_ilength (res) <= 0)
+ res = scm_cons2 (SCM_IM_BEGIN, res, SCM_EOL);
+
+ SCM_DEFER_INTS;
+ SCM_SETCAR (x, SCM_CAR (res));
+ SCM_SETCDR (x, SCM_CDR (res));
+ SCM_ALLOW_INTS;
+
+ goto macro_tail;
+}
+