remove more Racket-to-C compiler leftovers

This commit is contained in:
Matthew Flatt 2011-11-20 08:27:00 -07:00
parent 3da3e17c47
commit ea3cabfc45
4 changed files with 0 additions and 2597 deletions

View File

@ -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)

View File

@ -1,2 +0,0 @@
#define LOCAL_PROC(x) x

File diff suppressed because it is too large Load Diff

View File

@ -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)))