remove more Racket-to-C compiler leftovers
This commit is contained in:
Matthew Flatt
parent
3da3e17c47
commit
ea3cabfc45
|
|
@ -1,366 +0,0 @@
|
|||
|
||||
#include <stdlib.h>
|
||||
#include <stdarg.h>
|
||||
|
||||
#define GLOBAL_VARREF(x) ((x)->val ? (Scheme_Object *)(x)->val : \
|
||||
(scheme_unbound_global(x), (Scheme_Object *)NULL))
|
||||
#define CHECK_GLOBAL_BOUND(x) \
|
||||
if (!(x)->val) scheme_raise_exn(MZEXN_UNIT, \
|
||||
"invoke-unit: cannot link to undefined identifier: %S", \
|
||||
(Scheme_Object*)(x)->key);
|
||||
|
||||
#ifdef NO_INLINE_KEYWORD
|
||||
# define MZC_INLINE /* */
|
||||
#else
|
||||
# define MZC_INLINE MSC_IZE(inline)
|
||||
#endif
|
||||
|
||||
#define MZC_GLOBAL_PREPARE(vec, pos) (SCHEME_VEC_ELS(vec)[pos] = SCHEME_PTR1_VAL(SCHEME_VEC_ELS(vec)[pos]))
|
||||
static MZC_INLINE Scheme_Object *MZC_GLOBAL_LOOKUP(Scheme_Object *vec, int pos) {
|
||||
Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos];
|
||||
Scheme_Object *o = bucket->val;
|
||||
if (o)
|
||||
return o;
|
||||
else {
|
||||
scheme_unbound_global(bucket);
|
||||
return NULL;
|
||||
}
|
||||
}
|
||||
|
||||
static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos, Scheme_Object *val) {
|
||||
Scheme_Bucket *bucket = (Scheme_Bucket *)SCHEME_VEC_ELS(vec)[pos];
|
||||
scheme_set_global_bucket("set!", bucket, val, 0);
|
||||
return scheme_void;
|
||||
}
|
||||
|
||||
#define MZC_KNOWN_SAFE_VECTOR_REF(vec, pos) (SCHEME_VEC_ELS(vec)[pos])
|
||||
|
||||
#define MZC_APPLY_MAGIC(val, n) \
|
||||
scheme_eval_compiled_sized_string_with_magic(top_level_bytecode_ ## n, sizeof(top_level_bytecode_ ## n), NULL, \
|
||||
scheme_intern_symbol(top_level_magic_sym_ ## n), val, 1)
|
||||
|
||||
#define DO_FUEL_POLL ((scheme_fuel_counter-- <= 0) ? (scheme_process_block(0), 0) : 0)
|
||||
|
||||
#define _scheme_direct_apply_primitive_multi_poll(prim, argc, argv) \
|
||||
(DO_FUEL_POLL, _scheme_direct_apply_primitive_multi(prim, argc, argv))
|
||||
#define _scheme_direct_apply_primitive_poll(prim, argc, argv) \
|
||||
(DO_FUEL_POLL, _scheme_direct_apply_primitive(prim, argc, argv))
|
||||
#define _scheme_direct_apply_primitive_closure_multi_poll(prim, argc, argv) \
|
||||
(DO_FUEL_POLL, _scheme_direct_apply_primitive_closure_multi(prim, argc, argv))
|
||||
#define _scheme_direct_apply_primitive_closure_poll(prim, argc, argv) \
|
||||
(DO_FUEL_POLL, _scheme_direct_apply_primitive_closure(prim, argc, argv))
|
||||
|
||||
#ifdef KEEP_CLOSURE_COUNT
|
||||
static int closure_alloc_cnt;
|
||||
static void print_closures()
|
||||
{
|
||||
printf("closures allocated in " MZC_SRC_FILE ": %d\n", closure_alloc_cnt);
|
||||
}
|
||||
# define CLOSURE_ALLOC_PP closure_alloc_inc(),
|
||||
static void closure_alloc_inc()
|
||||
{
|
||||
if (!closure_alloc_cnt)
|
||||
atexit(print_closures);
|
||||
closure_alloc_cnt++;
|
||||
}
|
||||
#else
|
||||
# define CLOSURE_ALLOC_PP /**/
|
||||
#endif
|
||||
|
||||
typedef struct {
|
||||
Scheme_Primitive_Proc prim;
|
||||
#ifdef MZ_PRECISE_GC
|
||||
int count;
|
||||
#endif
|
||||
} Scheme_Primitive_Closure_Post;
|
||||
|
||||
# define MZC_INSTALL_DATA_PTR(rec) rec
|
||||
# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned long *)(((Scheme_Primitive_Closure *)void_param)->val)
|
||||
# define MZC_ENV_POINTER(t, ct, void_param) (&(((const ct *)void_param)->data))
|
||||
|
||||
|
||||
#ifdef SIXTY_FOUR_BIT_INTEGERS
|
||||
# define MZ_LOG_WORD_SIZE 4
|
||||
#else
|
||||
# define MZ_LOG_WORD_SIZE 2
|
||||
#endif
|
||||
|
||||
#define _scheme_make_c_proc_closure(cfunc, rec, name, amin, amax, flags) \
|
||||
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
|
||||
name, amin, amax, flags, \
|
||||
sizeof(rec->data)>>MZ_LOG_WORD_SIZE))
|
||||
|
||||
#define _scheme_make_c_proc_closure_empty(cfunc, rec, name, amin, amax, flags) \
|
||||
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure(&rec->prim, cfunc, name, amin, amax, flags))
|
||||
|
||||
#define _scheme_make_c_case_proc_closure(cfunc, rec, name, ccnt, cses, flags) \
|
||||
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
|
||||
name, ccnt, cses, flags, \
|
||||
sizeof(rec->data)>>MZ_LOG_WORD_SIZE))
|
||||
|
||||
#define _scheme_make_c_case_proc_closure_empty(cfunc, rec, name, ccnt, cses, flags) \
|
||||
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure(&rec->prim, cfunc, name, ccnt, cses, flags))
|
||||
|
||||
#define NO_MULTIPLE_VALUES(res) \
|
||||
if (res == SCHEME_MULTIPLE_VALUES) \
|
||||
scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
|
||||
#define CHECK_MULTIPLE_VALUES(res, expected) \
|
||||
if (res != SCHEME_MULTIPLE_VALUES || scheme_multiple_count != expected) \
|
||||
scheme_wrong_return_arity(NULL, expected, \
|
||||
(res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_count : 1), \
|
||||
(res == SCHEME_MULTIPLE_VALUES ? scheme_multiple_array : (Scheme_Object**)res), \
|
||||
NULL);
|
||||
|
||||
#define SCHEME_DETATCH_MV_BUFFER(mv, pr) if (SAME_OBJ(mv, pr->values_buffer)) pr->values_buffer = NULL
|
||||
|
||||
#define SCHEME_CURRENT_ENV(pr) scheme_get_env(NULL)
|
||||
|
||||
typedef struct {
|
||||
Scheme_Object * val;
|
||||
Scheme_Object ** array;
|
||||
int count;
|
||||
} _Scheme_Begin0_Rec;
|
||||
|
||||
typedef struct {
|
||||
Scheme_Cont_Frame_Data cf;
|
||||
Scheme_Object *val;
|
||||
} _Scheme_WCM_Rec;
|
||||
|
||||
#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure(f, argc, argv) : _scheme_apply(f, argc, argv))
|
||||
#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_prim_closure_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv))
|
||||
|
||||
#define MZC_EQP(ltp, av, bv) (SAME_OBJ(av, bv))
|
||||
#define MZC_EQVP(ltp, av, bv) (SAME_OBJ(av, bv) || scheme_eqv(av, bv))
|
||||
#define MZC_EQUALP(ltp, av, bv) scheme_equal(av, bv)
|
||||
#define MZC_NOTP(p, av) (SCHEME_FALSEP(av))
|
||||
#define MZC_NULLP(p, av) (SCHEME_NULLP(av))
|
||||
#define MZC_PAIRP(p, av) (SCHEME_PAIRP(av))
|
||||
#define MZC_SYMBOLP(p, av) (SCHEME_SYMBOLP(av))
|
||||
#define MZC_STRINGP(p, av) (SCHEME_CHAR_STRINGP(av))
|
||||
#define MZC_BYTESP(p, av) (SCHEME_BYTE_STRINGP(av))
|
||||
#define MZC_VECTORP(p, av) (SCHEME_VECTORP(av))
|
||||
#define MZC_NUMBERP(p, av) (SCHEME_NUMBERP(av))
|
||||
#define MZC_PROCEDUREP(p, av) (SCHEME_PROCP(av))
|
||||
#define MZC_EOFP(p, av) (SCHEME_EOFP(av))
|
||||
#define MZC_CHARP(p, av) (SCHEME_CHARP(av))
|
||||
|
||||
#define MZC_CONS(p, av, bv) scheme_make_pair(av, bv)
|
||||
#define MZC_LIST1(p, av) scheme_make_pair(av, scheme_null)
|
||||
#define MZC_LIST2(p, av, bv) scheme_make_pair(av, scheme_make_pair(bv, scheme_null))
|
||||
#define MZC_APPEND(p, av, bv) scheme_append(av, bv)
|
||||
|
||||
#define MZC_FOR_SYNTAX_IN_ENV(ignored, proc) scheme_apply_for_syntax_in_env(proc, env)
|
||||
|
||||
#if MZC_UNSAFE
|
||||
/* Unsafe versions */
|
||||
#define MZC_CAR(p, av) SCHEME_CAR(av)
|
||||
#define MZC_CDR(p, av) SCHEME_CDR(av)
|
||||
#define MZC_CADR(p, av) SCHEME_CAR(SCHEME_CDR(av))
|
||||
#define MZC_CDDR(p, av) SCHEME_CDR(SCHEME_CDR(av))
|
||||
#define MZC_CDAR(p, av) SCHEME_CDR(SCHEME_CAR(av))
|
||||
#define MZC_CAAR(p, av) SCHEME_CAR(SCHEME_CAR(av))
|
||||
#define MZC_CADDR(p, av) SCHEME_CADR(SCHEME_CDR(av))
|
||||
#define MZC_SET_CAR(p, av, bv) (SCHEME_CAR(av)=bv, scheme_void)
|
||||
#define MZC_SET_CDR(p, av, bv) (SCHEME_CDR(av)=bv, scheme_void)
|
||||
|
||||
# define MZC_VECTOR_REF(p, v, i) SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)]
|
||||
# define MZC_VECTOR_SET(p, v, i, x) (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void)
|
||||
|
||||
# define MZC_STRING_REF(p, v, i) scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)])
|
||||
# define MZC_STRING_SET(p, v, i, x) (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void)
|
||||
|
||||
# define MZC_BYTES_REF(p, v, i) scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)])
|
||||
# define MZC_BYTES_SET(p, v, i, x) (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void)
|
||||
|
||||
#define MZC_CHAR_TO_INTEGER(p, v) scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v))
|
||||
/* End unsafe versions */
|
||||
#else
|
||||
/* Safe versions */
|
||||
#define MZC_CAR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CAR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CDR(p, av) (SCHEME_PAIRP(av) ? SCHEME_CDR(av) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CADR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CAR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CDDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av))) ? SCHEME_CDR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CDAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CDR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CAAR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CAR(av))) ? SCHEME_CAR(SCHEME_CAR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_CADDR(p, av) ((SCHEME_PAIRP(av) && SCHEME_PAIRP(SCHEME_CDR(av)) && SCHEME_PAIRP(SCHEME_CDR(SCHEME_CDR(av)))) ? SCHEME_CADR(SCHEME_CDR(av)) : (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_SET_CAR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CAR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg)))
|
||||
#define MZC_SET_CDR(p, av, bv) (SCHEME_MUTABLE_PAIRP(av) ? (SCHEME_CDR(av)=bv, scheme_void) : (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(p, 2, arg)))
|
||||
|
||||
#define MZC_CHAR_TO_INTEGER(p, v) (SCHEME_CHARP(v) ? scheme_make_integer((unsigned char)SCHEME_CHAR_VAL(v)) \
|
||||
: (arg[0] = v, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
|
||||
# define MZC_VECTOR_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \
|
||||
&& (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \
|
||||
? SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] \
|
||||
: (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
|
||||
# define MZC_VECTOR_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_VECTORP(v) && (SCHEME_INT_VAL(i) >= 0) \
|
||||
&& (SCHEME_INT_VAL(i) < SCHEME_VEC_SIZE(v)) \
|
||||
? (SCHEME_VEC_ELS(v)[SCHEME_INT_VAL(i)] = x, scheme_void) \
|
||||
: (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
|
||||
# define MZC_STRING_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_CHAR_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \
|
||||
&& (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \
|
||||
? scheme_make_character(SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)]) \
|
||||
: (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
|
||||
# define MZC_STRING_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_CHAR_STRINGP(v) && SCHEME_CHARP(x) && (SCHEME_INT_VAL(i) >= 0) \
|
||||
&& (SCHEME_INT_VAL(i) < SCHEME_CHAR_STRLEN_VAL(v)) \
|
||||
? (SCHEME_CHAR_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_CHAR_VAL(x), scheme_void) \
|
||||
: (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
|
||||
# define MZC_BYTES_REF(p, v, i) ((SCHEME_INTP(i) && SCHEME_BYTE_STRINGP(v) && (SCHEME_INT_VAL(i) >= 0) \
|
||||
&& (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \
|
||||
? scheme_make_integer(SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)]) \
|
||||
: (arg[0] = v, arg[1] = i, _scheme_direct_apply_primitive_multi(p, 2, arg))))
|
||||
# define MZC_BYTES_SET(p, v, i, x) ((SCHEME_INTP(i) && SCHEME_MUTABLE_BYTE_STRINGP(v) && SCHEME_INTP(x) \
|
||||
&& (SCHEME_INT_VAL(x) >= 0) && (SCHEME_INT_VAL(x) <= 255) \
|
||||
&& (SCHEME_INT_VAL(i) >= 0) && (SCHEME_INT_VAL(i) < SCHEME_BYTE_STRLEN_VAL(v)) \
|
||||
? (SCHEME_BYTE_STR_VAL(v)[SCHEME_INT_VAL(i)] = SCHEME_INT_VAL(x), scheme_void) \
|
||||
: (arg[0] = v, arg[1] = i, arg[2] = x, _scheme_direct_apply_primitive_multi(p, 3, arg))))
|
||||
/* End safe versions */
|
||||
#endif
|
||||
|
||||
#define _MZC_DBLP(obj) SAME_TYPE(_SCHEME_TYPE(obj), scheme_double_type)
|
||||
|
||||
#define MZC_ZEROP(zp, av) (SCHEME_INTP(av) \
|
||||
? (av == scheme_make_integer(0)) \
|
||||
: (_MZC_DBLP(av) \
|
||||
? !SCHEME_DBL_VAL(av) \
|
||||
: (arg[0] = av, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(zp, 1, arg)))))
|
||||
|
||||
#define MZC_ARITH_COMPARE(cp, av, bv, compareop) \
|
||||
((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
|
||||
? (SCHEME_INT_VAL(av) compareop SCHEME_INT_VAL(bv)) \
|
||||
: ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
|
||||
? (SCHEME_DBL_VAL(av) compareop SCHEME_DBL_VAL(bv)) \
|
||||
: (arg[0] = av, arg[1] = bv, SCHEME_TRUEP(_scheme_direct_apply_primitive_multi(cp, 2, arg)))))
|
||||
|
||||
#define MZC_LTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <)
|
||||
#define MZC_GTP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >)
|
||||
#define MZC_LTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, <=)
|
||||
#define MZC_GTEP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, >=)
|
||||
#define MZC_EQLP(cp, av, bv) MZC_ARITH_COMPARE(cp, av, bv, ==)
|
||||
|
||||
#if MZC_FIXNUM
|
||||
/* Numerically incorrect */
|
||||
#define MZC_ADD1(p, av) (SCHEME_INTP(av) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av)+1) \
|
||||
: (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_SUB1(p, av) (SCHEME_INTP(av) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av)-1) \
|
||||
: (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
|
||||
#define MZC_ARITH_OP(cp, av, bv, op, revop) \
|
||||
((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \
|
||||
: ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
|
||||
? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \
|
||||
: (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))))
|
||||
|
||||
#define MZC_TIMES2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, *, /)
|
||||
|
||||
/* End numerically incorrect */
|
||||
#else
|
||||
/* Numerically correct */
|
||||
#define MZC_ADD1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) < 0x3FFFFFFF)) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av)+1) \
|
||||
: (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
#define MZC_SUB1(p, av) ((SCHEME_INTP(av) && (SCHEME_INT_VAL(av) > (-0x3FFFFFFF))) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av)-1) \
|
||||
: (arg[0] = av, _scheme_direct_apply_primitive_multi(p, 1, arg)))
|
||||
|
||||
#define MZC_ARITH_OP(cp, av, bv, op, revop) \
|
||||
((SCHEME_INTP(av) && SCHEME_INTP(bv) \
|
||||
&& (((SCHEME_INT_VAL(scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv))) \
|
||||
revop SCHEME_INT_VAL(bv)) \
|
||||
== SCHEME_INT_VAL(av)))) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av) op SCHEME_INT_VAL(bv)) \
|
||||
: ((SCHEME_DBLP(av) && SCHEME_DBLP(bv)) \
|
||||
? scheme_make_double(SCHEME_DBL_VAL(av) op SCHEME_DBL_VAL(bv)) \
|
||||
: (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg))))
|
||||
/* End numerically correct */
|
||||
#endif
|
||||
|
||||
#define MZC_PLUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, +, -)
|
||||
#define MZC_MINUS2(cp, av, bv) MZC_ARITH_OP(cp, av, bv, -, +)
|
||||
|
||||
#define MZC_MAXMIN_OP(cp, av, bv, minlt) \
|
||||
((SCHEME_INTP(av) && SCHEME_INTP(bv)) \
|
||||
? ((SCHEME_INT_VAL(av) minlt SCHEME_INT_VAL(bv)) ? av : bv) \
|
||||
: (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))
|
||||
|
||||
#define MZC_MAX2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, >)
|
||||
#define MZC_MIN2(cp, av, bv) MZC_MAXMIN_OP(cp, av, bv, <)
|
||||
|
||||
#define MZC_QUOTIENT(cp, av, bv) \
|
||||
((SCHEME_INTP(av) && SCHEME_INTP(bv) && SCHEME_INT_VAL(bv)) \
|
||||
? scheme_make_integer(SCHEME_INT_VAL(av) / SCHEME_INT_VAL(bv)) \
|
||||
: (arg[0] = av, arg[1] = bv, _scheme_direct_apply_primitive_multi(cp, 2, arg)))
|
||||
|
||||
static MSC_IZE(inline) Scheme_Object *mzc_force_value(Scheme_Object *v)
|
||||
{
|
||||
return _scheme_force_value(v);
|
||||
}
|
||||
|
||||
#define _scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv) \
|
||||
mzc_force_value(_scheme_direct_apply_primitive_closure_multi(prim, argc, argv))
|
||||
#define _scheme_direct_apply_primitive_closure_fv(prim, argc, argv) \
|
||||
scheme_check_one_value(_scheme_direct_apply_primitive_closure_multi_fv(prim, argc, argv))
|
||||
|
||||
static int mzc_strlen(const char *c) {
|
||||
int l;
|
||||
for (l = 0; c[l]; l++);
|
||||
return l;
|
||||
}
|
||||
|
||||
#if 0
|
||||
static Scheme_Object *DEBUG_CHECK(Scheme_Object *v)
|
||||
{
|
||||
if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) {
|
||||
/* Could be a boxed value ... */
|
||||
Scheme_Object *o = *(Scheme_Object **)v;
|
||||
if ((SCHEME_TYPE(v) < _scheme_values_types_) || (SCHEME_TYPE(v) > _scheme_last_type_ + 5)) {
|
||||
printf("wrong!\n");
|
||||
}
|
||||
}
|
||||
return v;
|
||||
}
|
||||
#endif
|
||||
|
||||
#ifdef MZ_PRECISE_GC
|
||||
START_XFORM_SUSPEND;
|
||||
static MZC_INLINE Scheme_Object *
|
||||
_mzc_direct_apply_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
|
||||
{
|
||||
return _scheme_direct_apply_primitive_multi(prim, argc, argv);
|
||||
}
|
||||
static MZC_INLINE Scheme_Object *
|
||||
_mzc_direct_apply_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
|
||||
{
|
||||
return _scheme_direct_apply_primitive(prim, argc, argv);
|
||||
}
|
||||
static MZC_INLINE Scheme_Object *
|
||||
_mzc_direct_apply_primitive_closure_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
|
||||
{
|
||||
return _scheme_direct_apply_primitive_closure_multi(prim, argc, argv);
|
||||
}
|
||||
static MZC_INLINE Scheme_Object *
|
||||
_mzc_direct_apply_primitive_closure(Scheme_Object *prim, int argc, Scheme_Object **argv)
|
||||
{
|
||||
return _scheme_direct_apply_primitive_closure(prim, argc, argv);
|
||||
}
|
||||
END_XFORM_SUSPEND;
|
||||
#else
|
||||
# define _mzc_direct_apply_primitive_multi(prim, argc, argv) \
|
||||
_scheme_direct_apply_primitive_multi(prim, argc, argv)
|
||||
# define _mzc_direct_apply_primitive(prim, argc, argv) \
|
||||
_scheme_direct_apply_primitive(prim, argc, argv)
|
||||
# define _mzc_direct_apply_primitive_closure_multi(prim, argc, argv) \
|
||||
_scheme_direct_apply_primitive_closure_multi(prim, argc, argv)
|
||||
# define _mzc_direct_apply_primitive_closure(prim, argc, argv) \
|
||||
_scheme_direct_apply_primitive_closure(prim, argc, argv)
|
||||
#endif
|
||||
|
||||
#define _mzc_apply(r,n,rs) _scheme_apply(r,n,rs)
|
||||
#define _mzc_apply_multi(r,n,rs) _scheme_apply_multi(r,n,rs)
|
||||
#define _mzc_apply_known_prim_closure(r,n,rs) _scheme_apply_known_prim_closure(r,n,rs)
|
||||
#define _mzc_apply_known_prim_closure_multi(r,n,rs) _scheme_apply_known_prim_closure_multi(r,n,rs)
|
||||
|
||||
#define MZC_PRIM_CLS_DATA(prim) (prim)
|
||||
|
|
@ -1,2 +0,0 @@
|
|||
|
||||
#define LOCAL_PROC(x) x
|
||||
File diff suppressed because it is too large
Load Diff
|
|
@ -1,422 +0,0 @@
|
|||
(module to-core scheme/base
|
||||
(require syntax/kerncase
|
||||
syntax/stx
|
||||
mzlib/list
|
||||
syntax/boundmap
|
||||
(for-syntax scheme/base))
|
||||
|
||||
(provide top-level-to-core)
|
||||
|
||||
;; `module', `require', and `require-for-syntax' declarations must
|
||||
;; not be embedded in a `begin' sequence. For `require' and
|
||||
;; `require-for-syntax', it's a timing issue. For `module', it's
|
||||
;; because the transformation can only handle a single `module'
|
||||
;; declaration.
|
||||
(define (top-level-to-core stx lookup-stx set-stx safe-vector-ref-stx extract-stx
|
||||
simple-constant? stop-properties)
|
||||
(syntax-case stx (module begin)
|
||||
[(module m lang (plain-module-begin decl ...))
|
||||
(let-values ([(expr new-decls magic-sym)
|
||||
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
|
||||
lookup-stx set-stx safe-vector-ref-stx extract-stx
|
||||
#t
|
||||
simple-constant? stop-properties)])
|
||||
(values (expand-syntax expr)
|
||||
#`(module m lang (#%plain-module-begin #,@new-decls))
|
||||
magic-sym))]
|
||||
[(begin decl ...)
|
||||
(let-values ([(expr new-decls magic-sym)
|
||||
(lift-sequence (flatten-decls (syntax->list #'(decl ...)))
|
||||
lookup-stx set-stx safe-vector-ref-stx extract-stx
|
||||
#f
|
||||
simple-constant? stop-properties)])
|
||||
(values (expand-syntax expr)
|
||||
#`(begin #,@new-decls)
|
||||
magic-sym))]
|
||||
[else
|
||||
(top-level-to-core #`(begin #,stx) lookup-stx set-stx safe-vector-ref-stx extract-stx
|
||||
simple-constant? stop-properties)]))
|
||||
|
||||
(define (flatten-decls l)
|
||||
(apply append
|
||||
(map (lambda (stx)
|
||||
(syntax-case stx (begin)
|
||||
[(begin . e)
|
||||
(flatten-decls (syntax->list #'e))]
|
||||
[else (list stx)]))
|
||||
l)))
|
||||
|
||||
(define-struct lifted-info ([counter #:mutable] id-map slot-map))
|
||||
|
||||
(define (make-vars)
|
||||
(make-lifted-info
|
||||
0
|
||||
(make-module-identifier-mapping)
|
||||
(make-hash)))
|
||||
|
||||
(define (is-id-ref? v)
|
||||
(or (identifier? v)
|
||||
(and (stx-pair? v)
|
||||
(identifier? (stx-car v))
|
||||
(free-identifier=? #'#%top (stx-car v)))))
|
||||
|
||||
(define (vars-sequence li)
|
||||
(let loop ([i 0])
|
||||
(if (= i (lifted-info-counter li))
|
||||
null
|
||||
(cons (let ([v (hash-ref (lifted-info-slot-map li) i)])
|
||||
(if (is-id-ref? v)
|
||||
#`(#%variable-reference #,v)
|
||||
v))
|
||||
(loop (add1 i))))))
|
||||
|
||||
(define (extract-vars li vec-id extract-stx)
|
||||
(let loop ([i 0])
|
||||
(if (= i (lifted-info-counter li))
|
||||
null
|
||||
(let ([v (hash-ref (lifted-info-slot-map li) i)])
|
||||
(if (is-id-ref? v)
|
||||
(cons #`(#,extract-stx #,vec-id #,i)
|
||||
(loop (add1 i)))
|
||||
(loop (add1 i)))))))
|
||||
|
||||
(define (is-run-time? stx)
|
||||
(not (and (stx-pair? stx)
|
||||
(or (free-identifier=? #'define-syntaxes (stx-car stx))
|
||||
(free-identifier=? #'define-values-for-syntax (stx-car stx))))))
|
||||
|
||||
(define (has-symbol? decl magic-sym table)
|
||||
(cond
|
||||
[(hash-ref table decl (lambda () #f))
|
||||
;; cycle/graph
|
||||
#f]
|
||||
[else
|
||||
(hash-set! table decl #t)
|
||||
(cond
|
||||
[(eq? magic-sym decl)
|
||||
#t]
|
||||
[(pair? decl)
|
||||
(or (has-symbol? (car decl) magic-sym table)
|
||||
(has-symbol? (cdr decl) magic-sym table))]
|
||||
[(vector? decl)
|
||||
(has-symbol? (vector->list decl) magic-sym table)]
|
||||
[(box? decl)
|
||||
(has-symbol? (unbox decl) magic-sym table)]
|
||||
[else
|
||||
#f])]))
|
||||
|
||||
(define (generate-magic decls)
|
||||
(let ([magic-sym (string->symbol (format "magic~a~a"
|
||||
(current-seconds)
|
||||
(current-milliseconds)))])
|
||||
(if (has-symbol? (map syntax->datum decls) magic-sym (make-hasheq))
|
||||
(generate-magic decls)
|
||||
magic-sym)))
|
||||
|
||||
(define (need-thunk? rhs)
|
||||
(not (and (stx-pair? rhs)
|
||||
(or (free-identifier=? #'lambda (stx-car rhs))
|
||||
(free-identifier=? #'case-lambda (stx-car rhs))))))
|
||||
|
||||
(define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx
|
||||
in-module? simple-constant? stop-properties)
|
||||
(let ([ct-vars (make-vars)]
|
||||
[rt-vars (make-vars)]
|
||||
[compile-time (datum->syntax #f (gensym 'compile-time))]
|
||||
[run-time (datum->syntax #f (gensym 'run-time))]
|
||||
[magic-sym (generate-magic decls)]
|
||||
[magic-indirect (gensym)])
|
||||
(let ([ct-converted
|
||||
(map (lambda (stx)
|
||||
#`(lambda ()
|
||||
#,(syntax-case stx ()
|
||||
[(def ids rhs)
|
||||
(let ([cvted (convert #'rhs #t
|
||||
lookup-stx set-stx safe-vector-ref-stx
|
||||
compile-time ct-vars
|
||||
in-module?
|
||||
simple-constant? stop-properties)])
|
||||
(if (and (not in-module?)
|
||||
(free-identifier=? #'def #'define-syntaxes))
|
||||
;; Don't try to name macro procedures, because it
|
||||
;; inteferes with the 0-values hack at the top level
|
||||
cvted
|
||||
#`(let-values ([ids #,cvted])
|
||||
(#%plain-app values . ids))))])))
|
||||
(filter (lambda (x) (not (is-run-time? x))) decls))]
|
||||
[rt-converted
|
||||
(map (lambda (stx)
|
||||
(syntax-case stx (define-values
|
||||
#%provide
|
||||
#%require)
|
||||
[(#%provide . _)
|
||||
#'void]
|
||||
[(#%require . _)
|
||||
#'void]
|
||||
[(define-values ids rhs)
|
||||
(let ([converted (convert #'rhs #f
|
||||
lookup-stx set-stx safe-vector-ref-stx
|
||||
run-time rt-vars
|
||||
in-module?
|
||||
simple-constant? stop-properties)])
|
||||
(if (need-thunk? #'rhs)
|
||||
#`(lambda () #,converted)
|
||||
#`(let-values ([ids #,converted])
|
||||
(#%plain-app values . ids))))]
|
||||
[else
|
||||
#`(lambda ()
|
||||
#,(convert stx #f
|
||||
lookup-stx set-stx safe-vector-ref-stx
|
||||
run-time rt-vars
|
||||
in-module?
|
||||
simple-constant? stop-properties))]))
|
||||
(filter is-run-time? decls))]
|
||||
[ct-rhs #`(#%plain-app
|
||||
(let-values ([(magic) (#%plain-app car (#%plain-app cons '#,magic-sym 2))])
|
||||
(if (#%plain-app symbol? magic)
|
||||
(#%plain-lambda (x)
|
||||
(#%plain-app
|
||||
vector
|
||||
#,@(map (lambda (stx)
|
||||
(syntax-case stx ()
|
||||
[(def (id) . _)
|
||||
#'void]
|
||||
[(def (id ...) . _)
|
||||
(with-syntax ([(v ...) (map (lambda (x) #f)
|
||||
(syntax->list #'(id ...)))])
|
||||
|
||||
#`(#%plain-lambda () (#%plain-app values v ...)))]))
|
||||
(filter (lambda (x) (not (is-run-time? x))) decls))))
|
||||
(#%plain-app car magic)))
|
||||
(#%plain-app vector #,@(vars-sequence ct-vars)))]
|
||||
[rt-rhs #`(#%plain-app (#%plain-app cdr '#,magic-sym)
|
||||
(#%plain-app vector #,@(vars-sequence rt-vars)))]
|
||||
[just-one-ct? (>= 1 (apply +
|
||||
(map (lambda (decl)
|
||||
(syntax-case decl (define-syntaxes define-values-for-syntax)
|
||||
[(define-values-for-syntax . _) 1]
|
||||
[(define-syntaxes . _) 1]
|
||||
[_else 0]))
|
||||
decls)))]
|
||||
[just-one-rt? (>= 1 (apply +
|
||||
(map (lambda (decl)
|
||||
(syntax-case decl (define-values #%provide #%require
|
||||
define-syntaxes define-values-for-syntax)
|
||||
[(#%provide . _) 0]
|
||||
[(#%require . _) 0]
|
||||
[(define-values-for-syntax . _) 0]
|
||||
[(define-syntaxes . _) 0]
|
||||
[_else 1]))
|
||||
decls)))])
|
||||
(values
|
||||
#`(#%plain-app
|
||||
cons (#%plain-lambda (#,compile-time)
|
||||
#,@(extract-vars ct-vars compile-time extract-stx)
|
||||
(#%plain-app vector #,@ct-converted))
|
||||
(#%plain-lambda (#,run-time)
|
||||
#,@(extract-vars rt-vars run-time extract-stx)
|
||||
(#%plain-app vector #,@rt-converted)))
|
||||
#`(;; Lift require and require-for-syntaxes to the front, so they're ready for
|
||||
;; variable references
|
||||
#,@(filter (lambda (decl)
|
||||
(syntax-case decl (#%require)
|
||||
[(#%require . _) #t]
|
||||
[_else #f]))
|
||||
decls)
|
||||
;; Lift define-for-values binding to front, so they can be referenced
|
||||
;; in compile-time definition
|
||||
#,@(let ([ids (apply
|
||||
append
|
||||
(map (lambda (stx)
|
||||
(syntax-case stx (define-values-for-syntax)
|
||||
[(define-values-for-syntax ids . _)
|
||||
(syntax->list #'ids)]
|
||||
[_else null]))
|
||||
decls))])
|
||||
(if (null? ids)
|
||||
null
|
||||
#`((define-values-for-syntax #,ids
|
||||
(values #,@(map (lambda (x) #'#f) ids))))))
|
||||
#,@(if just-one-ct?
|
||||
null
|
||||
#`((define-values-for-syntax (#,compile-time) #,ct-rhs)))
|
||||
#,@(if just-one-rt?
|
||||
null
|
||||
#`((define-values (#,run-time) #,rt-rhs)))
|
||||
#,@(let loop ([decls decls][ct-pos 0][rt-pos 0])
|
||||
(cond
|
||||
[(null? decls) null]
|
||||
[(is-run-time? (car decls))
|
||||
(cons (syntax-case (car decls) (define-values #%provide #%require)
|
||||
[(#%provide . _)
|
||||
(car decls)]
|
||||
[(#%require . _)
|
||||
#'(#%plain-app void)]
|
||||
[(define-values (id ...) rhs)
|
||||
#`(define-values (id ...)
|
||||
#,(let ([lookup #`(#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos)])
|
||||
(if (need-thunk? #'rhs)
|
||||
#`(#%plain-app #,lookup)
|
||||
lookup)))]
|
||||
[else
|
||||
#`(#%plain-app (#%plain-app vector-ref #,(if just-one-rt? rt-rhs run-time) #,rt-pos))])
|
||||
(loop (cdr decls) ct-pos (add1 rt-pos)))]
|
||||
[else
|
||||
(cons (syntax-case (car decls) (define-syntaxes define-values-for-syntax)
|
||||
[(define-syntaxes (id ...) . rhs)
|
||||
#`(define-syntaxes (id ...)
|
||||
(#%plain-app (#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time) #,ct-pos)))]
|
||||
[(define-values-for-syntax (id ...) . rhs)
|
||||
#`(define-values-for-syntax ()
|
||||
(begin
|
||||
(set!-values (id ...)
|
||||
(#%plain-app
|
||||
(#%plain-app vector-ref #,(if just-one-ct? ct-rhs compile-time)
|
||||
#,ct-pos)))
|
||||
(#%plain-app values)))])
|
||||
(loop (cdr decls) (add1 ct-pos) rt-pos))])))
|
||||
magic-sym))))
|
||||
|
||||
(define (local-identifier? stx trans?)
|
||||
(eq? 'lexical ((if trans?
|
||||
identifier-transformer-binding
|
||||
identifier-binding)
|
||||
stx)))
|
||||
|
||||
(define (simple-identifier stx trans?)
|
||||
(let ([b ((if trans?
|
||||
identifier-transformer-binding
|
||||
identifier-binding)
|
||||
stx)])
|
||||
(cond
|
||||
[(eq? b 'lexical) stx]
|
||||
[(and (pair? b)
|
||||
(eq? '#%kernel (car b)))
|
||||
;; Generate a syntax object that has the right run-time binding:
|
||||
(datum->syntax #'here (cadr b) stx stx)]
|
||||
[else #f])))
|
||||
|
||||
(define (add-literal/pos stx li)
|
||||
(let ([pos (lifted-info-counter li)])
|
||||
(hash-set! (lifted-info-slot-map li) pos stx)
|
||||
(set-lifted-info-counter! li (add1 pos))
|
||||
pos))
|
||||
|
||||
(define (add-literal stx li safe-vector-ref-stx id)
|
||||
#`(#,safe-vector-ref-stx #,id #,(add-literal/pos stx li)))
|
||||
|
||||
(define (add-identifier/pos stx li trans?)
|
||||
(if (identifier? stx)
|
||||
;; id :
|
||||
(or (module-identifier-mapping-get (lifted-info-id-map li)
|
||||
stx
|
||||
(lambda () #f))
|
||||
(let ([pos (add-literal/pos (if (not ((if trans?
|
||||
identifier-transformer-binding
|
||||
identifier-binding)
|
||||
stx))
|
||||
#`(#%top . #,stx)
|
||||
stx)
|
||||
li)])
|
||||
(module-identifier-mapping-put! (lifted-info-id-map li) stx pos)
|
||||
pos))
|
||||
;; (#%top . id) :
|
||||
(add-literal/pos stx li)))
|
||||
|
||||
(define (add-identifier stx li trans? lookup-stx id)
|
||||
#`(#,lookup-stx #,id #,(add-identifier/pos stx li trans?)))
|
||||
|
||||
(define-syntax quasisyntax/loc+props
|
||||
(syntax-rules ()
|
||||
[(_ stx e) (let ([old-s stx]
|
||||
[new-s (quasisyntax e)])
|
||||
(datum->syntax new-s
|
||||
(syntax-e new-s)
|
||||
old-s
|
||||
old-s))]))
|
||||
(define code-insp (current-code-inspector))
|
||||
|
||||
(define (convert stx trans? lookup-stx set-stx safe-vector-ref-stx id li in-module?
|
||||
simple-constant? stop-properties)
|
||||
(define (loop stx)
|
||||
(if (ormap (lambda (prop)
|
||||
(syntax-property stx prop))
|
||||
stop-properties)
|
||||
stx
|
||||
(kernel-syntax-case (syntax-disarm stx code-insp) trans?
|
||||
[_
|
||||
(identifier? stx)
|
||||
(or (simple-identifier stx trans?)
|
||||
(add-identifier stx li trans? lookup-stx id))]
|
||||
[(#%provide . _)
|
||||
stx]
|
||||
[(#%plain-lambda formals e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(#%plain-lambda formals #,@(map loop (syntax->list #'(e ...)))))]
|
||||
[(case-lambda [formals e ...] ...)
|
||||
(with-syntax ([((e ...) ...)
|
||||
(map (lambda (l)
|
||||
(map loop (syntax->list l)))
|
||||
(syntax->list #'((e ...) ...)))])
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(case-lambda [formals e ...] ...)))]
|
||||
[(let-values ([(id ...) rhs] ...) e ...)
|
||||
(with-syntax ([(rhs ...)
|
||||
(map loop (syntax->list #'(rhs ...)))])
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(let-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
|
||||
[(letrec-values ([(id ...) rhs] ...) e ...)
|
||||
(with-syntax ([(rhs ...)
|
||||
(map loop (syntax->list #'(rhs ...)))])
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(letrec-values ([(id ...) rhs] ...) #,@(map loop (syntax->list #'(e ...))))))]
|
||||
[(quote e)
|
||||
(if (simple-constant? #'e)
|
||||
#'(quote e)
|
||||
(add-literal stx li safe-vector-ref-stx id))]
|
||||
[(quote-syntax e)
|
||||
(add-literal stx li safe-vector-ref-stx id)]
|
||||
[(#%top . tid)
|
||||
(let ([target (let ([b ((if trans?
|
||||
identifier-transformer-binding
|
||||
identifier-binding)
|
||||
#'tid)])
|
||||
(if (or (eq? b 'lexical)
|
||||
(and (not in-module?)
|
||||
b))
|
||||
#`(#%top . tid)
|
||||
#'tid))])
|
||||
(add-identifier target li trans? lookup-stx id))]
|
||||
[(set! x e)
|
||||
(if (local-identifier? #'x trans?)
|
||||
(quasisyntax/loc+props stx (set! x #,(loop #'e)))
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(#,set-stx #,id #,(add-identifier/pos #'x li trans?) #,(loop #'e))))]
|
||||
[(#%variable-reference e)
|
||||
(add-literal stx li safe-vector-ref-stx id)]
|
||||
[(if e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(if #,@(map loop (syntax->list #'(e ...)))))]
|
||||
[(begin e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(begin #,@(map loop (syntax->list #'(e ...)))))]
|
||||
[(begin0 e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(begin0 #,@(map loop (syntax->list #'(e ...)))))]
|
||||
[(with-continuation-mark e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(with-continuation-mark #,@(map loop (syntax->list #'(e ...)))))]
|
||||
[(#%plain-app e ...)
|
||||
(quasisyntax/loc+props
|
||||
stx
|
||||
(#%plain-app #,@(map loop (syntax->list #'(e ...)))))])))
|
||||
(loop stx)))
|
||||
Loading…
Reference in New Issue
Block a user