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