suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

301.7

Browse Source 
svn: r2304
This commit is contained in:
Matthew Flatt 2006-02-23 13:19:03 +00:00
parent 702e89c492
commit e40e27435d
27 changed files with 1063 additions and 940 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

70
collects/compiler/mzc.h
View File

@ -45,10 +45,10 @@ static MZC_INLINE Scheme_Object *MZC_GLOBAL_ASSIGN(Scheme_Object *vec, int pos,
(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_closed_primitive_multi_poll(prim, argc, argv) \
(DO_FUEL_POLL, _scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
#define _scheme_direct_apply_closed_primitive_poll(prim, argc, argv) \
(DO_FUEL_POLL, _scheme_direct_apply_closed_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;
@ -67,31 +67,39 @@ static void closure_alloc_inc()
# 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 int *)((Scheme_Closed_Primitive_Post_Ext_Proc *)void_param)->a
# 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 MZC_INSTALL_DATA_PTR(rec) &rec->data
# define MZC_PARAM_TO_SWITCH(void_param) *(unsigned int*)void_param
# define MZC_ENV_POINTER(t, ct, void_param) ((const t *)void_param)
# 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(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
name, amin, amax, flags, \
sizeof(rec->data)>>2))
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, NULL, 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(&rec->prim, cfunc, MZC_INSTALL_DATA_PTR(rec), \
(CLOSURE_ALLOC_PP (Scheme_Object *)_scheme_fill_prim_case_closure_post(((Scheme_Primitive_Closure *)&rec->prim), cfunc, \
name, ccnt, cses, flags, \
sizeof(rec->data)>>2))
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, NULL, 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) \
@ -118,8 +126,8 @@ typedef struct {
Scheme_Object *val;
} _Scheme_WCM_Rec;
#define _scheme_apply_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim(f, argc, argv) : _scheme_apply(f, argc, argv))
#define _scheme_apply_multi_ckp(f, argc, argv) (SCHEME_CLSD_PRIMP(f) ? _scheme_apply_closed_prim_multi(f, argc, argv) : _scheme_apply_multi(f, argc, argv))
#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))
@ -291,10 +299,10 @@ static MSC_IZE(inline) Scheme_Object *mzc_force_value(Scheme_Object *v)
return _scheme_force_value(v);
}
#define _scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv) \
mzc_force_value(_scheme_direct_apply_closed_primitive_multi(prim, argc, argv))
#define _scheme_direct_apply_closed_primitive_fv(prim, argc, argv) \
scheme_check_one_value(_scheme_direct_apply_closed_primitive_multi_fv(prim, argc, argv))
#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;
@ -329,14 +337,14 @@ _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_closed_primitive_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
_mzc_direct_apply_primitive_closure_multi(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_closed_primitive_multi(prim, argc, argv);
return _scheme_direct_apply_primitive_closure_multi(prim, argc, argv);
}
static MZC_INLINE Scheme_Object *
_mzc_direct_apply_closed_primitive(Scheme_Object *prim, int argc, Scheme_Object **argv)
_mzc_direct_apply_primitive_closure(Scheme_Object *prim, int argc, Scheme_Object **argv)
{
return _scheme_direct_apply_closed_primitive(prim, argc, argv);
return _scheme_direct_apply_primitive_closure(prim, argc, argv);
}
END_XFORM_SUSPEND;
#else
@ -344,13 +352,15 @@ END_XFORM_SUSPEND;
_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_closed_primitive_multi(prim, argc, argv) \
_scheme_direct_apply_closed_primitive_multi(prim, argc, argv)
# define _mzc_direct_apply_closed_primitive(prim, argc, argv) \
_scheme_direct_apply_closed_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_closed_prim(r,n,rs) _scheme_apply_known_closed_prim(r,n,rs)
#define _mzc_apply_known_closed_prim_multi(r,n,rs) _scheme_apply_known_closed_prim_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)

30
collects/compiler/private/vm2c.ss
View File

@ -417,7 +417,7 @@
number
(cond
[(procedure-vehicle? v)
"void * void_param, int argc, Scheme_Object *argv[]"]
"int argc, Scheme_Object *argv[], Scheme_Object *void_param"]
[else
(compiler:internal-error
#f
@ -494,10 +494,10 @@
[(scheme-bucket) "Scheme_Bucket *"]
[(scheme-per-load-static) "struct Scheme_Per_Load_Statics *"]
[(label) "int"]
[(prim) "Scheme_Closed_Primitive_Post_Proc"]
[(prim-empty) "Scheme_Closed_Primitive_Proc"]
[(prim-case) "Scheme_Closed_Case_Primitive_Post_Proc"]
[(prim-case-empty) "Scheme_Closed_Case_Primitive_Proc"]
[(prim) "Scheme_Primitive_Closure_Post"]
[(prim-empty) "Scheme_Primitive_Proc"]
[(prim-case) "Scheme_Primitive_Closure_Post"]
[(prim-case-empty) "Scheme_Primitive_Proc"]
[(begin0-saver) "_Scheme_Begin0_Rec"]
[(wcm-saver) "_Scheme_WCM_Rec"]
[else (compiler:internal-error
@ -1331,12 +1331,12 @@
(let ([c (vm:tail-apply-argc ast)])
(emit ", ~a, ~a, scheme_current_thread)" c (if (zero? c) "NULL" 'tail_buf)))]
;; (tail-call <label> <closure>) -> void_param = SCHEME_CLSD_PRIM_DATA(<closure>);
;; (tail-call <label> <closure>) -> void_param = MZC_PRIM_CLS_DATA(<closure>);
;; goto LOC<label>;
[(vm:tail-call? ast)
(when (vm:tail-call-set-env? ast)
(emit-indentation)
(emit "void_param = SCHEME_CLSD_PRIM_DATA(")
(emit "void_param = MZC_PRIM_CLS_DATA(")
(process (vm:tail-call-closure ast) indent-level #f #t)
(emit ");~n"))
;; be nice to threads & user breaks:
@ -1400,8 +1400,8 @@
(not (memq (object-name v) (internal-tail-chain-prims))))
(if (or (vm:apply-multi? ast)
(primitive-result-arity v))
"direct_apply_closed_primitive_multi"
"direct_apply_closed_primitive")]
"direct_apply_primitive_closure_multi"
"direct_apply_primitive_closure")]
[(and (primitive? v)
(not (memq (object-name v) (internal-tail-chain-prims))))
(if (or (vm:apply-multi? ast)
@ -1411,13 +1411,13 @@
[(vm:apply-known? ast)
(if (vm:apply-multi? ast)
(if (compiler:option:disable-interrupts)
"direct_apply_closed_primitive_multi_fv"
"apply_known_closed_prim_multi")
"direct_apply_primitive_closure_multi_fv"
"apply_known_prim_closure_multi")
(if (compiler:option:disable-interrupts)
(if (compiler:option:unsafe)
"direct_apply_closed_primitive_multi_fv"
"direct_apply_closed_primitive_fv")
"apply_known_closed_prim"))]
"direct_apply_primitive_closure_multi_fv"
"direct_apply_primitive_closure_fv")
"apply_known_prim_closure"))]
[(vm:apply-multi? ast) "apply_multi"]
[else "apply"])))
(process (vm:apply-closure ast) indent-level #f #t)
@ -1438,7 +1438,7 @@
(emit ", ~a)" top_level_n))]
[(vm:call? ast)
(emit-expr "_scheme_force_value(compiled(SCHEME_CLSD_PRIM_DATA(")
(emit-expr "_scheme_force_value(compiled(MZC_PRIM_CLS_DATA(")
(process (vm:call-closure ast) indent-level #f #t)
(emit "), 0, arg))")]

127
collects/tests/mzscheme/contmark.ss
View File

@ -154,51 +154,92 @@
v)
'x))))
;; full continuation, mark replaced
(wcm-test '(11 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(let/cc k
(with-continuation-mark 'x 12
k)))
(+ 2 3)))])
(continuation-mark-set->list
(continuation-marks k)
'x))))
;; continuation, mark replaced
(let* ([extract
(lambda (k)
(continuation-mark-set->list
(continuation-marks k)
'x))]
[go
(lambda (call/xc in?)
(wcm-test '(11 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(call/xc
(lambda (k )
(with-continuation-mark 'x 12
(if in?
(extract k)
k)))))
(+ 2 3)))])
(if in?
k
(extract k))))))])
(go call/cc #t)
(go call/cc #f)
(go call/ec #t))
;; nested full continuation, mark replaced
(wcm-test '(12 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(let/cc k0
(with-continuation-mark 'x 12
(let/cc k
k))))
(+ 2 3)))])
(continuation-mark-set->list
(continuation-marks k)
'x))))
;; nested continuation, mark replaced
(let* ([extract
(lambda (k)
(continuation-mark-set->list
(continuation-marks k)
'x))]
[go
(lambda (call/xc in?)
(wcm-test '(12 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(call/xc
(lambda (k0)
(with-continuation-mark 'x 12
(call/xc
(lambda (k)
(if in?
(extract k)
k)))))))
(+ 2 3)))])
(if in?
k
(extract k))))))])
(go call/cc #t)
(go call/cc #f)
(go call/ec #t))
;; nested full continuation, mark shared
(wcm-test '(12 11 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(let/cc k0
(begin0
(with-continuation-mark 'x 12
(let/cc k
k))
(cons 4 5))))
(cons 2 3)))])
(continuation-mark-set->list
(continuation-marks k)
'x))))
;; nested continuation, mark shared
(let* ([extract
(lambda (k)
(continuation-mark-set->list
(continuation-marks k)
'x))]
[go
(lambda (call/xc in?)
(wcm-test '(12 11 10)
(lambda ()
(let ([k (with-continuation-mark 'x 10
(begin0
(with-continuation-mark 'x 11
(call/xc
(lambda (k0)
(begin0
(with-continuation-mark 'x 12
(call/xc
(lambda (k)
(if in?
(extract k)
k))))
(cons 4 5)))))
(cons 2 3)))])
(if in?
k
(extract k))))))])
(go call/cc #t)
(go call/cc #f)
(go call/ec #t))
;; escape continuation, same thread
(wcm-test '(11 10)

13
notes/mzscheme/HISTORY
View File

@ -1,4 +1,17 @@
Version 301.7
Inside MzScheme: added scheme_make_prim_closure_w_arity(), etc.
Version 301.6
The body of `let/cc' and the procedure passed to `call/ec' are
evaluated/called as a tail expression/call
Added struct-type-make-constructor and struct-type-make-predicate
Added JIT support for 3m
Version 301.5
For nested captured continuations, the shared continuation tail is
represented by shared data
Version 301.4
Added just-in-time native-code compiler with a new eval-jit-enabled
parameter

8
src/configure vendored
View File

@ -8291,14 +8291,6 @@ fi
fi
if test "${no_x}" = "yes" ; then
echo "******************************************************"
echo "configure: cannot find X11 headers and/or libraries,"
echo " which are needed to compile MrEd"
echo "******************************************************"
echo configure aborted
exit 1
fi
fi
MAKE_MRED=mr

8
src/mzscheme/configure.ac
View File

@ -304,14 +304,6 @@ if test "${enable_mred}" = "yes" ; then
:
else
AC_PATH_XTRA
if test "${no_x}" = "yes" ; then
echo "******************************************************"
echo "configure: cannot find X11 headers and/or libraries,"
echo " which are needed to compile MrEd"
echo "******************************************************"
echo configure aborted
exit 1
fi
fi
MAKE_MRED=mr

14
src/mzscheme/include/mzscheme.exp
View File

@ -116,10 +116,10 @@ scheme_apply_to_list
scheme_eval_string
scheme_eval_string_multi
scheme_eval_string_all
_scheme_apply_known_closed_prim
_scheme_apply_known_closed_prim_multi
_scheme_apply_closed_prim
_scheme_apply_closed_prim_multi
_scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure
_scheme_apply_prim_closure_multi
scheme_values
scheme_check_one_value
scheme_tail_apply
@ -181,14 +181,16 @@ scheme_is_hash_table_equal
scheme_clone_hash_table
scheme_make_prim
scheme_make_noneternal_prim
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_prim_w_everything
scheme_make_prim_closure_w_arity
scheme_make_folding_prim_closure
scheme_make_closed_prim
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim
scheme_make_prim_w_everything
scheme_make_closed_prim_w_everything
scheme_prim_is_method
scheme_make_pair

14
src/mzscheme/include/mzscheme3m.exp
View File

@ -116,10 +116,10 @@ scheme_apply_to_list
scheme_eval_string
scheme_eval_string_multi
scheme_eval_string_all
_scheme_apply_known_closed_prim
_scheme_apply_known_closed_prim_multi
_scheme_apply_closed_prim
_scheme_apply_closed_prim_multi
_scheme_apply_known_prim_closure
_scheme_apply_known_prim_closure_multi
_scheme_apply_prim_closure
_scheme_apply_prim_closure_multi
scheme_values
scheme_check_one_value
scheme_tail_apply
@ -188,14 +188,16 @@ scheme_is_hash_table_equal
scheme_clone_hash_table
scheme_make_prim
scheme_make_noneternal_prim
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_prim_w_everything
scheme_make_prim_closure_w_arity
scheme_make_folding_prim_closure
scheme_make_closed_prim
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim
scheme_make_prim_w_everything
scheme_make_closed_prim_w_everything
scheme_prim_is_method
scheme_make_pair

6
src/mzscheme/include/mzwin.def
View File

@ -173,14 +173,16 @@ EXPORTS
scheme_clone_hash_table
scheme_make_prim
scheme_make_noneternal_prim
scheme_make_closed_prim
scheme_make_prim_w_arity
scheme_make_folding_prim
scheme_make_noncm_prim
scheme_make_noneternal_prim_w_arity
scheme_make_prim_w_everything
scheme_make_prim_closure_w_arity
scheme_make_folding_prim_closure
scheme_make_closed_prim
scheme_make_closed_prim_w_arity
scheme_make_folding_closed_prim
scheme_make_prim_w_everything
scheme_make_closed_prim_w_everything
scheme_prim_is_method
scheme_make_pair

143
src/mzscheme/include/scheme.h
View File

@ -193,10 +193,6 @@ extern "C"
typedef short Scheme_Type;
/* Used to use `short' for app arg counts, etc., but adding limit
checks is difficult, and seems arbitrary. We can switch back
to short if the expense turns out to be noticable; in that case
also define MZSHORT_IS_SHORT. */
typedef int mzshort;
typedef unsigned int mzchar;
@ -577,17 +573,17 @@ typedef void (*Scheme_Type_Printer)(Scheme_Object *v, int for_display, Scheme_Pr
#define SCHEME_PRIM_IS_BINARY_INLINED 512
#define SCHEME_PRIM_IS_USER_PARAMETER 1024
#define SCHEME_PRIM_IS_METHOD 2048
#define SCHEME_PRIM_IS_POST_DATA 4096
#define SCHEME_PRIM_IS_CLOSURE 4096
#define SCHEME_PRIM_IS_NONCM 8192
#define SCHEME_PRIM_IS_UNARY_INLINED 16384
#define SCHEME_PRIM_PROC_FLAGS(x) (((Scheme_Prim_Proc_Header *)x)->flags)
typedef struct Scheme_Object *
(Scheme_Prim)(int argc, struct Scheme_Object *argv[]);
typedef struct Scheme_Object *(Scheme_Prim)(int argc, Scheme_Object *argv[]);
typedef struct Scheme_Object *
(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
typedef struct Scheme_Object *(Scheme_Primitive_Closure_Proc)(int argc, struct Scheme_Object *argv[], Scheme_Object *p);
#define SCHEME_MAX_ARGS 0x3FFFFFFE
typedef struct {
Scheme_Object so;
@ -596,16 +592,40 @@ typedef struct {
typedef struct {
Scheme_Prim_Proc_Header pp;
Scheme_Prim *prim_val;
Scheme_Primitive_Closure_Proc *prim_val;
const char *name;
mzshort mina, maxa;
mzshort mina;
/* If mina < 0; mina is negated case count minus one for a case-lambda
generated by mzc, where the primitive checks argument arity
itself, and mu.cases is available instead of mu.maxa. */
union {
mzshort *cases;
mzshort maxa; /* > SCHEME_MAX_ARGS => any number of arguments */
} mu;
} Scheme_Primitive_Proc;
typedef struct {
Scheme_Primitive_Proc pp;
mzshort minr, maxr;
/* Never combined with a closure */
} Scheme_Prim_W_Result_Arity;
typedef struct Scheme_Primitive_Closure {
Scheme_Primitive_Proc p;
/* The rest is here only if SCHEME_PRIM_IS_CLOSURE
is set in p.pp.flags. */
#ifdef MZ_PRECISE_GC
mzshort count;
#endif
Scheme_Object *val[1];
} Scheme_Primitive_Closure;
#define SCHEME_PRIM_CLOSURE_ELS(p) ((Scheme_Primitive_Closure *)p)->val
/* ------ Old-style primitive closures ------- */
typedef struct Scheme_Object *(Scheme_Closed_Prim)(void *d, int argc, struct Scheme_Object *argv[]);
typedef struct {
Scheme_Prim_Proc_Header pp;
Scheme_Closed_Prim *prim_val;
@ -627,88 +647,45 @@ typedef struct {
/* ------------------------------------------------- */
/* mzc closure glue
The following structures are used by mzc to implement closures
where the closure data is allocated as part of the
Scheme_Closed_Primitive_Proc record. In 3m mode, a length must be
included, and all of the closur-data elements are assumed to be
pointers. Furthermore, in 3m mode, a cases and non-cases closure
must have closure data starting at the same point, since two
kinds can flow to the same MZC_PARAM_TO_SWITCH().
The following are used by mzc to implement closures.
*/
typedef struct {
union {
Scheme_Closed_Primitive_Proc p;
#ifdef MZ_PRECISE_GC
Scheme_Closed_Case_Primitive_Proc other;
#endif
} u;
#ifdef MZ_PRECISE_GC
mzshort len;
#endif
} Scheme_Closed_Primitive_Post_Proc;
typedef struct {
Scheme_Closed_Primitive_Post_Proc p;
void *a[1];
} Scheme_Closed_Primitive_Post_Ext_Proc;
typedef struct {
union {
Scheme_Closed_Case_Primitive_Proc p;
#ifdef MZ_PRECISE_GC
Scheme_Closed_Primitive_Proc other;
#endif
} u;
#ifdef MZ_PRECISE_GC
mzshort len;
#endif
} Scheme_Closed_Case_Primitive_Post_Proc;
typedef struct {
Scheme_Closed_Case_Primitive_Post_Proc p;
void *a[1];
} Scheme_Closed_Case_Primitive_Post_Ext_Proc;
#define _scheme_fill_prim_closure(rec, cfunc, dt, nm, amin, amax, flgs) \
((rec)->pp.so.type = scheme_closed_prim_type, \
#define _scheme_fill_prim_closure(rec, cfunc, nm, amin, amax, flgs) \
((rec)->pp.so.type = scheme_prim_type, \
(rec)->prim_val = cfunc, \
(rec)->data = (void *)(dt), \
(rec)->name = nm, \
(rec)->mina = amin, \
(rec)->maxa = amax, \
(rec)->mina = amin, \
(rec)->mu.maxa = (amax == -1 ? SCHEME_MAX_ARGS + 1 : amax), \
(rec)->pp.flags = flgs, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
((rec)->len = ln, \
_scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, \
flgs | SCHEME_PRIM_IS_POST_DATA))
# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
((rec)->count = ln, \
_scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, \
flgs | SCHEME_PRIM_IS_CLOSURE))
#else
# define _scheme_fill_prim_closure_post(rec, cfunc, dt, nm, amin, amax, flgs, ln) \
_scheme_fill_prim_closure(&(rec)->u.p, cfunc, dt, nm, amin, amax, flgs)
# define _scheme_fill_prim_closure_post(rec, cfunc, nm, amin, amax, flgs, ln) \
_scheme_fill_prim_closure(&(rec)->p, cfunc, nm, amin, amax, flgs)
#endif
#define _scheme_fill_prim_case_closure(rec, cfunc, dt, nm, ccount, cses, flgs) \
((rec)->p.pp.so.type = scheme_closed_prim_type, \
(rec)->p.prim_val = cfunc, \
(rec)->p.data = (void *)(dt), \
(rec)->p.name = nm, \
(rec)->p.mina = -2, \
(rec)->p.maxa = -(ccount), \
(rec)->p.pp.flags = flgs, \
(rec)->cases = cses, \
#define _scheme_fill_prim_case_closure(rec, cfunc, nm, ccount, cses, flgs) \
((rec)->pp.so.type = scheme_prim_type, \
(rec)->prim_val = cfunc, \
(rec)->name = nm, \
(rec)->mina = -(ccount+1), \
(rec)->pp.flags = flgs, \
(rec)->mu.cases = cses, \
rec)
#ifdef MZ_PRECISE_GC
# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
((rec)->len = ln, \
_scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, \
flgs | SCHEME_PRIM_IS_POST_DATA))
# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
((rec)->count = ln, \
_scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, \
flgs | SCHEME_PRIM_IS_CLOSURE))
#else
# define _scheme_fill_prim_case_closure_post(rec, cfunc, dt, nm, ccount, cses, flgs, ln) \
_scheme_fill_prim_case_closure(&(rec)->u.p, cfunc, dt, nm, ccount, cses, flgs)
# define _scheme_fill_prim_case_closure_post(rec, cfunc, nm, ccount, cses, flgs, ln) \
_scheme_fill_prim_case_closure(&((rec)->p), cfunc, nm, ccount, cses, flgs)
#endif
/* ------------------------------------------------- */
@ -721,7 +698,7 @@ typedef struct {
#define SCHEME_ECONTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_escaping_cont_type)
#define SCHEME_CONT_MARK_SETP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_cont_mark_set_type)
#define SCHEME_PROC_STRUCTP(obj) SAME_TYPE(SCHEME_TYPE(obj), scheme_proc_struct_type)
#define SCHEME_STRUCT_PROCP(obj) (SCHEME_CLSD_PRIMP(obj) && (((Scheme_Closed_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
#define SCHEME_STRUCT_PROCP(obj) (SCHEME_PRIMP(obj) && (((Scheme_Primitive_Proc *)(obj))->pp.flags & SCHEME_PRIM_IS_STRUCT_PROC))
#define SCHEME_CLOSUREP(obj) (SAME_TYPE(SCHEME_TYPE(obj), scheme_closure_type) || SAME_TYPE(SCHEME_TYPE(obj), scheme_case_closure_type))
#define SCHEME_PRIM(obj) (((Scheme_Primitive_Proc *)(obj))->prim_val)
@ -1322,9 +1299,13 @@ typedef void (*Scheme_Invoke_Proc)(Scheme_Env *env, long phase_shift,
#define _scheme_tail_eval_wp scheme_tail_eval_wp
#define _scheme_direct_apply_primitive_multi(prim, argc, argv) \
(((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv))
(((Scheme_Primitive_Proc *)prim)->prim_val(argc, argv, prim))
#define _scheme_direct_apply_primitive(prim, argc, argv) \
scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
scheme_check_one_value(_scheme_direct_apply_primitive_multi(prim, argc, argv))
#define _scheme_direct_apply_primitive_closure_multi(prim, argc, argv) \
_scheme_direct_apply_primitive_multi(prim, argc, argv)
#define _scheme_direct_apply_primitive_closure(prim, argc, argv) \
_scheme_direct_apply_primitive(prim, argc, argv)
#define _scheme_direct_apply_closed_primitive_multi(prim, argc, argv) \
(((Scheme_Closed_Primitive_Proc *)prim)->prim_val(((Scheme_Closed_Primitive_Proc *)prim)->data, argc, argv))
#define _scheme_direct_apply_closed_primitive(prim, argc, argv) \

726
src/mzscheme/src/cstartup.inc
View File

File diff suppressed because it is too large Load Diff

13
src/mzscheme/src/error.c
View File

@ -988,6 +988,9 @@ void scheme_wrong_count_m(const char *name, int minc, int maxc,
if (!argc || !minc)
is_method = 0;
if (maxc > SCHEME_MAX_ARGS)
maxc = -1;
s = make_arity_expect_string(name, -1, minc, maxc, argc, argv, &len, is_method);
scheme_raise_exn(MZEXN_FAIL_CONTRACT_ARITY, "%t", s, len);
@ -1028,7 +1031,15 @@ char *scheme_make_arity_expect_string(Scheme_Object *proc,
if (SCHEME_PRIMP(proc)) {
name = ((Scheme_Primitive_Proc *)proc)->name;
mina = ((Scheme_Primitive_Proc *)proc)->mina;
maxa = ((Scheme_Primitive_Proc *)proc)->maxa;
if (mina < 0) {
/* set min1 to -2 to indicates cases */
mina = -2;
maxa = 0;
} else {
maxa = ((Scheme_Primitive_Proc *)proc)->mu.maxa;
if (maxa > SCHEME_MAX_ARGS)
maxa = -1;
}
} else if (SCHEME_CLSD_PRIMP(proc)) {
name = ((Scheme_Closed_Primitive_Proc *)proc)->name;
mina = ((Scheme_Closed_Primitive_Proc *)proc)->mina;

82
src/mzscheme/src/eval.c
View File

@ -3647,9 +3647,9 @@ static Scheme_Object *do_apply_known_k(void)
p->ku.k.p2 = NULL;
return _scheme_apply_known_closed_prim_multi((Scheme_Object *)p->ku.k.p1,
p->ku.k.i1,
argv);
return _scheme_apply_known_prim_closure_multi((Scheme_Object *)p->ku.k.p1,
p->ku.k.i1,
argv);
}
#if 0
@ -3665,36 +3665,36 @@ static Scheme_Object *do_apply_known_k(void)
# define DEBUG_CHECK_TYPE(v) /**/
#endif
Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
Scheme_Object *_scheme_apply_known_prim_closure_multi(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_ARITY 0
#define PRIM_CHECK_MULTI 0
#include "schapp.inc"
}
Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_ARITY 1
#define PRIM_CHECK_MULTI 0
#include "schapp.inc"
}
Scheme_Object *_scheme_apply_known_closed_prim(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_ARITY 0
#define PRIM_CHECK_MULTI 1
#include "schapp.inc"
}
Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator,
int argc,
Scheme_Object **argv)
{
#define PRIM_CHECK_ARITY 1
#define PRIM_CHECK_MULTI 1
@ -3909,6 +3909,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
if (type == scheme_prim_type) {
GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
#define VACATE_TAIL_BUFFER_USE_RUNSTACK() \
if (rands == p->tail_buffer) { \
@ -3936,14 +3937,15 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
prim = (Scheme_Primitive_Proc *)obj;
if (num_rands < prim->mina
|| (num_rands > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count_m(prim->name, prim->mina, prim->maxa,
|| (num_rands > prim->mu.maxa && prim->mina >= 0)) {
scheme_wrong_count_m(prim->name, prim->mina, prim->mu.maxa,
num_rands, rands,
prim->pp.flags & SCHEME_PRIM_IS_METHOD);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(num_rands, rands);
f = prim->prim_val;
v = f(num_rands, rands, (Scheme_Object *)prim);
DEBUG_CHECK_TYPE(v);
} else if (type == scheme_closure_type) {
@ -4128,28 +4130,6 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
}
goto eval_top;
} else if (type == scheme_closed_prim_type) {
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
prim = (Scheme_Closed_Primitive_Proc *)obj;
if (num_rands < prim->mina
|| (num_rands > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count_m(prim->name, prim->mina, prim->maxa,
num_rands, rands,
prim->pp.flags & SCHEME_PRIM_IS_METHOD);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(prim->data, num_rands, rands);
DEBUG_CHECK_TYPE(v);
} else if (type == scheme_case_closure_type) {
Scheme_Case_Lambda *seq;
Scheme_Closure_Data *data;
@ -4361,6 +4341,28 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
goto apply_top;
} else if (type == scheme_closed_prim_type) {
GC_CAN_IGNORE Scheme_Closed_Primitive_Proc *prim;
DO_CHECK_FOR_BREAK(p, UPDATE_THREAD_RSPTR_FOR_GC(); if (rands == p->tail_buffer) make_tail_buffer_safe(););
VACATE_TAIL_BUFFER_USE_RUNSTACK();
UPDATE_THREAD_RSPTR();
prim = (Scheme_Closed_Primitive_Proc *)obj;
if (num_rands < prim->mina
|| (num_rands > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count_m(prim->name, prim->mina, prim->maxa,
num_rands, rands,
prim->pp.flags & SCHEME_PRIM_IS_METHOD);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(prim->data, num_rands, rands);
DEBUG_CHECK_TYPE(v);
} else {
UPDATE_THREAD_RSPTR_FOR_ERROR();
if (rands == p->tail_buffer)

274
src/mzscheme/src/fun.c
View File

@ -436,6 +436,57 @@ scheme_make_void (void)
/* primitive procedures */
/*========================================================================*/
static Scheme_Object *
make_prim_closure(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
int flags,
mzshort minr, mzshort maxr,
int closed, int count, Scheme_Object **vals)
{
Scheme_Primitive_Proc *prim;
int hasr, size;
hasr = ((minr != 1) || (maxr != 1));
size = (hasr
? sizeof(Scheme_Prim_W_Result_Arity)
: (closed
? (sizeof(Scheme_Primitive_Closure)
+ ((count - 1) * sizeof(Scheme_Object *)))
: sizeof(Scheme_Primitive_Proc)));
if (eternal && scheme_starting_up && !closed)
prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
else
prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
prim->pp.so.type = scheme_prim_type;
prim->prim_val = (Scheme_Primitive_Closure_Proc *)fun;
prim->name = name;
prim->mina = mina;
if (maxa < 0)
maxa = SCHEME_MAX_ARGS + 1;
prim->mu.maxa = maxa;
prim->pp.flags = (flags
| (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
| (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0)
| (closed ? SCHEME_PRIM_IS_CLOSURE : 0));
if (hasr) {
((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
}
if (closed) {
#ifdef MZ_PRECISE_GC
((Scheme_Primitive_Closure *)prim)->count = count;
#endif
memcpy(((Scheme_Primitive_Closure *)prim)->val,
vals,
count * sizeof(Scheme_Object *));
}
return (Scheme_Object *)prim;
}
Scheme_Object *
scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
const char *name,
@ -443,49 +494,33 @@ scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
int flags,
mzshort minr, mzshort maxr)
{
Scheme_Primitive_Proc *prim;
int hasr, size;
hasr = ((minr != 1) || (maxr != 1));
size = hasr ? sizeof(Scheme_Prim_W_Result_Arity) : sizeof(Scheme_Primitive_Proc);
if (eternal && scheme_starting_up)
prim = (Scheme_Primitive_Proc *)scheme_malloc_eternal_tagged(size);
else
prim = (Scheme_Primitive_Proc *)scheme_malloc_tagged(size);
prim->pp.so.type = scheme_prim_type;
SCHEME_PRIM(prim) = fun;
prim->name = name;
prim->mina = mina;
prim->maxa = maxa;
prim->pp.flags = (flags
| (scheme_defining_primitives ? SCHEME_PRIM_IS_PRIMITIVE : 0)
| (hasr ? SCHEME_PRIM_IS_MULTI_RESULT : 0));
if (hasr) {
((Scheme_Prim_W_Result_Arity *)prim)->minr = minr;
((Scheme_Prim_W_Result_Arity *)prim)->maxr = maxr;
}
return (Scheme_Object *)prim;
return make_prim_closure(fun, eternal,
name,
mina, maxa,
flags,
minr, maxr,
0, 0, NULL);
}
Scheme_Object *scheme_make_prim(Scheme_Prim *fun)
{
return scheme_make_prim_w_everything(fun, 1, NULL, 0, -1, 0, 1, 1);
return make_prim_closure(fun, 1, NULL, 0, -1, 0, 1, 1,
0, 0, NULL);
}
Scheme_Object *
scheme_make_noneternal_prim (Scheme_Prim *fun)
{
return scheme_make_prim_w_everything(fun, 0, NULL, 0, -1, 0, 1, 1);
return make_prim_closure(fun, 0, NULL, 0, -1, 0, 1, 1,
0, 0, NULL);
}
Scheme_Object *
scheme_make_prim_w_arity(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa)
{
return scheme_make_prim_w_everything(fun, 1, name, mina, maxa, 0, 1, 1);
return make_prim_closure(fun, 1, name, mina, maxa, 0, 1, 1,
0, 0, NULL);
}
Scheme_Object *
@ -493,12 +528,13 @@ scheme_make_folding_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa,
short folding)
{
return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
(folding
? (SCHEME_PRIM_IS_FOLDING
| SCHEME_PRIM_IS_NONCM)
: 0),
1, 1);
return make_prim_closure(fun, 1, name, mina, maxa,
(folding
? (SCHEME_PRIM_IS_FOLDING
| SCHEME_PRIM_IS_NONCM)
: 0),
1, 1,
0, 0, NULL);
}
Scheme_Object *
@ -506,17 +542,44 @@ scheme_make_noncm_prim(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa)
{
/* A non-cm primitive leaves the mark stack unchanged when it returns,
and it can't return multiple values. */
return scheme_make_prim_w_everything(fun, 1, name, mina, maxa,
SCHEME_PRIM_IS_NONCM,
1, 1);
it can't return multiple values or a tail call, and it cannot
use its third argument (i.e., the closure pointer) */
return make_prim_closure(fun, 1, name, mina, maxa,
SCHEME_PRIM_IS_NONCM,
1, 1,
0, 0, NULL);
}
Scheme_Object *
scheme_make_noneternal_prim_w_arity(Scheme_Prim *fun, const char *name,
mzshort mina, mzshort maxa)
{
return scheme_make_prim_w_everything(fun, 0, name, mina, maxa, 0, 1, 1);
return make_prim_closure(fun, 0, name, mina, maxa, 0, 1, 1,
0, 0, NULL);
}
Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa)
{
return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa, 0, 1, 1,
1, size, vals);
}
Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa,
short functional)
{
return make_prim_closure((Scheme_Prim *)prim, 1, name, mina, maxa,
(functional
? SCHEME_PRIM_IS_FOLDING
: 0),
1, 1,
1, size, vals);
}
Scheme_Object *
@ -1716,77 +1779,28 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
{
Scheme_Type type;
mzshort mina, maxa;
int drop = 0;
int drop = 0, cases_count = 0;
mzshort *cases = NULL;
top:
type = SCHEME_TYPE(p);
if (type == scheme_prim_type) {
mina = ((Scheme_Primitive_Proc *)p)->mina;
maxa = ((Scheme_Primitive_Proc *)p)->maxa;
maxa = ((Scheme_Primitive_Proc *)p)->mu.maxa;
if (mina < 0) {
cases = ((Scheme_Primitive_Proc *)p)->mu.cases;
cases_count = -(mina + 1);
} else {
if (maxa > SCHEME_MAX_ARGS)
maxa = -1;
}
} else if (type == scheme_closed_prim_type) {
mina = ((Scheme_Closed_Primitive_Proc *)p)->mina;
maxa = ((Scheme_Closed_Primitive_Proc *)p)->maxa;
if (mina == -2) {
mzshort *cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
int count = -maxa, i;
if (a == -1) {
Scheme_Object *arity, *a, *last = NULL;
arity = scheme_alloc_list(count);
for (i = 0, a = arity; i < count; i++) {
Scheme_Object *av;
int mn, mx;
mn = cases[2 * i];
mx = cases[(2 * i) + 1];
if (mn >= drop) {
mn -= drop;
if (mx > 0)
mx -= drop;
av = scheme_make_arity(mn, mx);
SCHEME_CAR(a) = av;
last = a;
a = SCHEME_CDR(a);
}
}
/* If drop > 0, might have found no matches */
if (!SCHEME_NULLP(a)) {
if (last)
SCHEME_CDR(last) = scheme_null;
else
arity = scheme_null;
}
return arity;
}
if (a == -2) {
for (i = 0; i < count; i++) {
if (cases[(2 * i) + 1] < 0)
return scheme_true;
}
return scheme_false;
}
a += drop;
for (i = 0; i < count; i++) {
int na, xa;
na = cases[2 * i];
xa = cases[(2 * i) + 1];
if ((a >= na) && ((xa < 0) || (a <= xa)))
return scheme_true;
}
return scheme_false;
cases_count = -maxa;
cases = ((Scheme_Closed_Case_Primitive_Proc *)p)->cases;
}
} else if (type == scheme_cont_type || type == scheme_escaping_cont_type) {
mina = 0;
@ -1953,6 +1967,66 @@ Scheme_Object *scheme_get_or_check_arity(Scheme_Object *p, long a)
}
}
if (cases) {
int count = cases_count, i;
if (a == -1) {
Scheme_Object *arity, *a, *last = NULL;
arity = scheme_alloc_list(count);
for (i = 0, a = arity; i < count; i++) {
Scheme_Object *av;
int mn, mx;
mn = cases[2 * i];
mx = cases[(2 * i) + 1];
if (mn >= drop) {
mn -= drop;
if (mx > 0)
mx -= drop;
av = scheme_make_arity(mn, mx);
SCHEME_CAR(a) = av;
last = a;
a = SCHEME_CDR(a);
}
}
/* If drop > 0, might have found no matches */
if (!SCHEME_NULLP(a)) {
if (last)
SCHEME_CDR(last) = scheme_null;
else
arity = scheme_null;
}
return arity;
}
if (a == -2) {
for (i = 0; i < count; i++) {
if (cases[(2 * i) + 1] < 0)
return scheme_true;
}
return scheme_false;
}
a += drop;
for (i = 0; i < count; i++) {
int na, xa;
na = cases[2 * i];
xa = cases[(2 * i) + 1];
if ((a >= na) && ((xa < 0) || (a <= xa)))
return scheme_true;
}
return scheme_false;
}
if (a == -1) {
if (mina < drop)
return scheme_null;

27
src/mzscheme/src/jit.c
View File

@ -922,7 +922,7 @@ static int generate_direct_prim_tail_call(mz_jit_state *jitter, int num_rands)
JIT_UPDATE_THREAD_RSPTR();
}
jit_movi_i(JIT_R1, num_rands);
mz_prepare(2);
mz_prepare(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */
CHECK_LIMIT();
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R1);
@ -1042,7 +1042,7 @@ static int generate_direct_prim_non_tail_call(mz_jit_state *jitter, int num_rand
}
jit_movi_i(JIT_R1, num_rands);
mz_prepare(2);
mz_prepare(2); /* a prim takes 3 args, but a NONCM prim ignores the 3rd */
CHECK_LIMIT();
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R1);
@ -1152,14 +1152,15 @@ static int generate_non_tail_call(mz_jit_state *jitter, int num_rands, int direc
jit_ldxi_i(JIT_R0, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->mina);
ref7 = jit_bnei_i(jit_forward(), JIT_R0, num_rands);
/* Fast prim application */
jit_ldxi_p(JIT_V1, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->prim_val);
jit_ldxi_p(JIT_R1, JIT_V1, &((Scheme_Primitive_Proc *)0x0)->prim_val);
if (need_set_rs) {
JIT_UPDATE_THREAD_RSPTR();
}
mz_prepare(2);
mz_prepare(3);
jit_pusharg_p(JIT_V1);
jit_pusharg_p(JIT_RUNSTACK);
jit_pusharg_i(JIT_R0);
(void)mz_finishr(JIT_V1);
(void)mz_finishr(JIT_R1);
CHECK_LIMIT();
jit_retval(JIT_R0);
if (!multi_ok) {
@ -1291,8 +1292,8 @@ static int generate_app(Scheme_App_Rec *app, Scheme_Object **alt_rands, int num_
if (SCHEME_PRIMP(rator)) {
if ((num_rands >= ((Scheme_Primitive_Proc *)rator)->mina)
&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->maxa)
|| (((Scheme_Primitive_Proc *)rator)->maxa < 0))
&& ((num_rands <= ((Scheme_Primitive_Proc *)rator)->mu.maxa)
|| (((Scheme_Primitive_Proc *)rator)->mina < 0))
&& is_noncm(rator))
direct_prim = 1;
} else {
@ -2902,7 +2903,7 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
#else
int then_short_ok = 1;
#endif
START_JIT_DATA();
START_JIT_DATA();
#ifdef MZ_USE_JIT_PPC
/* It's possible that the code for a then
@ -3663,8 +3664,15 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
CHECK_LIMIT();
/* *** stack_cache_pop_code *** */
/* DANGER: this code must save and restore (or avoid)
any registers that a function call would normally save
and restore. JIT_AUX, which is used by things like jit_ldi,
is such a register for PPC. */
stack_cache_pop_code = jit_get_ip().ptr;
jit_movr_p(JIT_R0, JIT_RET);
#ifdef MZ_USE_JIT_PPC
jit_movr_p(JIT_R(3), JIT_AUX);
#endif
/* Decrement stack_cache_stack_pos */
jit_ldi_i(JIT_R1, &stack_cache_stack_pos);
jit_subi_i(JIT_R2, JIT_R1, 1);
@ -3676,6 +3684,9 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
(void)jit_movi_p(JIT_R2, &stack_cache_stack);
jit_ldxr_p(JIT_R2, JIT_R2, JIT_R1);
jit_movr_p(JIT_RET, JIT_R0);
#ifdef MZ_USE_JIT_PPC
jit_movr_p(JIT_AUX, JIT_R(3));
#endif
jit_jmpr(JIT_R2);
CHECK_LIMIT();

115
src/mzscheme/src/mzmark.c
View File

@ -650,31 +650,60 @@ static int prim_proc_SIZE(void *p) {
Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
return
((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
+ ((Scheme_Primitive_Closure *)prim)->count - 1)
: ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
}
static int prim_proc_MARK(void *p) {
Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
gcMARK(prim->name);
if (prim->mina < 0) {
gcMARK(prim->mu.cases);
}
if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
int i;
for (i = cc->count; i--; ) {
gcMARK(cc->val[i]);
}
}
return
((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
+ ((Scheme_Primitive_Closure *)prim)->count - 1)
: ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
}
static int prim_proc_FIXUP(void *p) {
Scheme_Primitive_Proc *prim = (Scheme_Primitive_Proc *)p;
gcFIXUP(prim->name);
if (prim->mina < 0) {
gcFIXUP(prim->mu.cases);
}
if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
int i;
for (i = cc->count; i--; ) {
gcFIXUP(cc->val[i]);
}
}
return
((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
+ ((Scheme_Primitive_Closure *)prim)->count - 1)
: ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
}
#define prim_proc_IS_ATOMIC 0
@ -688,14 +717,8 @@ static int closed_prim_proc_SIZE(void *p) {
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
}
static int closed_prim_proc_MARK(void *p) {
@ -703,23 +726,6 @@ static int closed_prim_proc_MARK(void *p) {
gcMARK(c->name);
gcMARK(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
@ -728,14 +734,8 @@ static int closed_prim_proc_MARK(void *p) {
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
}
static int closed_prim_proc_FIXUP(void *p) {
@ -743,23 +743,6 @@ static int closed_prim_proc_FIXUP(void *p) {
gcFIXUP(c->name);
gcFIXUP(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcFIXUP(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcFIXUP(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcFIXUP(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
@ -768,14 +751,8 @@ static int closed_prim_proc_FIXUP(void *p) {
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
}
#define closed_prim_proc_IS_ATOMIC 0

48
src/mzscheme/src/mzmarksrc.c
View File

@ -244,11 +244,24 @@ prim_proc {
mark:
gcMARK(prim->name);
if (prim->mina < 0) {
gcMARK(prim->mu.cases);
}
if (prim->pp.flags & SCHEME_PRIM_IS_CLOSURE) {
Scheme_Primitive_Closure *cc = (Scheme_Primitive_Closure *)prim;
int i;
for (i = cc->count; i--; ) {
gcMARK(cc->val[i]);
}
}
size:
((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc)));
((prim->pp.flags & SCHEME_PRIM_IS_CLOSURE)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Closure))
+ ((Scheme_Primitive_Closure *)prim)->count - 1)
: ((prim->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Prim_W_Result_Arity))
: gcBYTES_TO_WORDS(sizeof(Scheme_Primitive_Proc))));
}
closed_prim_proc {
@ -257,23 +270,6 @@ closed_prim_proc {
mark:
gcMARK(c->name);
gcMARK(SCHEME_CLSD_PRIM_DATA(c));
if (c->pp.flags & SCHEME_PRIM_IS_POST_DATA) {
if (c->mina == -2) {
Scheme_Closed_Case_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Case_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
} else {
Scheme_Closed_Primitive_Post_Ext_Proc *cc;
int i;
cc = (Scheme_Closed_Primitive_Post_Ext_Proc *)c;
for (i = cc->p.len; i--; ) {
gcMARK(cc->a[i]);
}
}
}
if (c->mina == -2) {
gcMARK(((Scheme_Closed_Case_Primitive_Proc *)c)->cases);
}
@ -282,14 +278,8 @@ closed_prim_proc {
((c->pp.flags & SCHEME_PRIM_IS_MULTI_RESULT)
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Prim_W_Result_Arity))
: ((c->mina == -2)
? ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Case_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc)))
: ((c->pp.flags & SCHEME_PRIM_IS_POST_DATA)
? (gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Post_Ext_Proc))
+ ((Scheme_Closed_Primitive_Post_Proc *)c)->len - 1)
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc)))));
? gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Case_Primitive_Proc))
: gcBYTES_TO_WORDS(sizeof(Scheme_Closed_Primitive_Proc))));
}
scm_closure {

17
src/mzscheme/src/schapp.inc
View File

@ -1,8 +1,9 @@
MZ_MARK_STACK_TYPE old_cont_mark_stack;
Scheme_Object *v;
Scheme_Closed_Primitive_Proc *prim;
Scheme_Thread *p = scheme_current_thread;
GC_CAN_IGNORE Scheme_Object *v;
GC_CAN_IGNORE Scheme_Primitive_Closure *prim;
GC_CAN_IGNORE Scheme_Thread *p = scheme_current_thread;
GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
#if !PRIM_NO_STACK_CHECK
# ifdef DO_STACK_CHECK
@ -33,11 +34,11 @@
DO_CHECK_FOR_BREAK(p, ;);
#endif
prim = (Scheme_Closed_Primitive_Proc *)rator;
prim = (Scheme_Primitive_Closure *)rator;
#if PRIM_CHECK_ARITY
if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
if (argc < prim->p.mina || (argc > prim->p.mu.maxa && prim->p.mina >= 0)) {
scheme_wrong_count(prim->p.name, prim->p.mina, prim->p.mu.maxa, argc, argv);
return NULL; /* Shouldn't get here */
}
#endif
@ -45,7 +46,9 @@
MZ_CONT_MARK_POS++;
old_cont_mark_stack = MZ_CONT_MARK_STACK;
v = prim->prim_val(prim->data, argc, argv);
f = prim->p.prim_val;
v = f(argc, argv, (Scheme_Object *)prim);
#if !PRIM_NO_CHECK_VALUE
v = _scheme_force_value(v);
#endif

43
src/mzscheme/src/schemef.h
View File

@ -253,14 +253,14 @@ MZ_EXTERN Scheme_Object *scheme_eval_string(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_multi(const char *str, Scheme_Env *env);
MZ_EXTERN Scheme_Object *scheme_eval_string_all(const char *str, Scheme_Env *env, int all);
MZ_EXTERN Scheme_Object *_scheme_apply_known_closed_prim(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_known_closed_prim_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_closed_prim(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_closed_prim_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_known_prim_closure_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *_scheme_apply_prim_closure_multi(Scheme_Object *rator, int argc,
Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_values(int c, Scheme_Object **v);
@ -389,7 +389,6 @@ MZ_EXTERN Scheme_Hash_Table *scheme_clone_hash_table(Scheme_Hash_Table *bt);
MZ_EXTERN Scheme_Object *scheme_make_prim(Scheme_Prim *prim);
MZ_EXTERN Scheme_Object *scheme_make_noneternal_prim(Scheme_Prim *prim);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data);
MZ_EXTERN Scheme_Object *scheme_make_prim_w_arity(Scheme_Prim *prim, const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_folding_prim(Scheme_Prim *prim,
@ -402,18 +401,30 @@ MZ_EXTERN Scheme_Object *scheme_make_noncm_prim(Scheme_Prim *prim,
MZ_EXTERN Scheme_Object *scheme_make_noneternal_prim_w_arity(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa,
short functional);
MZ_EXTERN Scheme_Object *scheme_make_prim_w_everything(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
int folding,
mzshort minr, mzshort maxr);
MZ_EXTERN Scheme_Object *scheme_make_prim_closure_w_arity(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_folding_prim_closure(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa,
short functional);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim(Scheme_Closed_Prim *prim, void *data);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_arity(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa);
MZ_EXTERN Scheme_Object *scheme_make_folding_closed_prim(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa,
short functional);
MZ_EXTERN Scheme_Object *scheme_make_closed_prim_w_everything(Scheme_Closed_Prim *fun,
void *data,
const char *name,

41
src/mzscheme/src/schemex.h
View File

@ -203,14 +203,14 @@ Scheme_Object *(*scheme_apply_to_list)(Scheme_Object *rator, Scheme_Object *args
Scheme_Object *(*scheme_eval_string)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_multi)(const char *str, Scheme_Env *env);
Scheme_Object *(*scheme_eval_string_all)(const char *str, Scheme_Env *env, int all);
Scheme_Object *(*_scheme_apply_known_closed_prim)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_known_closed_prim_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_closed_prim)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_closed_prim_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_known_prim_closure)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_known_prim_closure_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_prim_closure)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*_scheme_apply_prim_closure_multi)(Scheme_Object *rator, int argc,
Scheme_Object **argv);
Scheme_Object *(*scheme_values)(int c, Scheme_Object **v);
Scheme_Object *(*scheme_check_one_value)(Scheme_Object *v);
/* Tail calls - only use these when you're writing new functions/syntax */
@ -313,7 +313,6 @@ Scheme_Hash_Table *(*scheme_clone_hash_table)(Scheme_Hash_Table *bt);
/*========================================================================*/
Scheme_Object *(*scheme_make_prim)(Scheme_Prim *prim);
Scheme_Object *(*scheme_make_noneternal_prim)(Scheme_Prim *prim);
Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data);
Scheme_Object *(*scheme_make_prim_w_arity)(Scheme_Prim *prim, const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_folding_prim)(Scheme_Prim *prim,
@ -326,18 +325,28 @@ Scheme_Object *(*scheme_make_noncm_prim)(Scheme_Prim *prim,
Scheme_Object *(*scheme_make_noneternal_prim_w_arity)(Scheme_Prim *prim,
const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa,
short functional);
Scheme_Object *(*scheme_make_prim_w_everything)(Scheme_Prim *fun, int eternal,
const char *name,
mzshort mina, mzshort maxa,
int folding,
mzshort minr, mzshort maxr);
Scheme_Object *(*scheme_make_prim_closure_w_arity)(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_folding_prim_closure)(Scheme_Primitive_Closure_Proc *prim,
int size, Scheme_Object **vals,
const char *name,
mzshort mina, mzshort maxa,
short functional);
Scheme_Object *(*scheme_make_closed_prim)(Scheme_Closed_Prim *prim, void *data);
Scheme_Object *(*scheme_make_closed_prim_w_arity)(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa);
Scheme_Object *(*scheme_make_folding_closed_prim)(Scheme_Closed_Prim *prim,
void *data, const char *name,
mzshort mina, mzshort maxa,
short functional);
Scheme_Object *(*scheme_make_closed_prim_w_everything)(Scheme_Closed_Prim *fun,
void *data,
const char *name,

14
src/mzscheme/src/schemex.inc
View File

@ -124,10 +124,10 @@
scheme_extension_table->scheme_eval_string = scheme_eval_string;
scheme_extension_table->scheme_eval_string_multi = scheme_eval_string_multi;
scheme_extension_table->scheme_eval_string_all = scheme_eval_string_all;
scheme_extension_table->_scheme_apply_known_closed_prim = _scheme_apply_known_closed_prim;
scheme_extension_table->_scheme_apply_known_closed_prim_multi = _scheme_apply_known_closed_prim_multi;
scheme_extension_table->_scheme_apply_closed_prim = _scheme_apply_closed_prim;
scheme_extension_table->_scheme_apply_closed_prim_multi = _scheme_apply_closed_prim_multi;
scheme_extension_table->_scheme_apply_known_prim_closure = _scheme_apply_known_prim_closure;
scheme_extension_table->_scheme_apply_known_prim_closure_multi = _scheme_apply_known_prim_closure_multi;
scheme_extension_table->_scheme_apply_prim_closure = _scheme_apply_prim_closure;
scheme_extension_table->_scheme_apply_prim_closure_multi = _scheme_apply_prim_closure_multi;
scheme_extension_table->scheme_values = scheme_values;
scheme_extension_table->scheme_check_one_value = scheme_check_one_value;
scheme_extension_table->scheme_tail_apply = scheme_tail_apply;
@ -209,14 +209,16 @@
scheme_extension_table->scheme_clone_hash_table = scheme_clone_hash_table;
scheme_extension_table->scheme_make_prim = scheme_make_prim;
scheme_extension_table->scheme_make_noneternal_prim = scheme_make_noneternal_prim;
scheme_extension_table->scheme_make_closed_prim = scheme_make_closed_prim;
scheme_extension_table->scheme_make_prim_w_arity = scheme_make_prim_w_arity;
scheme_extension_table->scheme_make_folding_prim = scheme_make_folding_prim;
scheme_extension_table->scheme_make_noncm_prim = scheme_make_noncm_prim;
scheme_extension_table->scheme_make_noneternal_prim_w_arity = scheme_make_noneternal_prim_w_arity;
scheme_extension_table->scheme_make_prim_w_everything = scheme_make_prim_w_everything;
scheme_extension_table->scheme_make_prim_closure_w_arity = scheme_make_prim_closure_w_arity;
scheme_extension_table->scheme_make_folding_prim_closure = scheme_make_folding_prim_closure;
scheme_extension_table->scheme_make_closed_prim = scheme_make_closed_prim;
scheme_extension_table->scheme_make_closed_prim_w_arity = scheme_make_closed_prim_w_arity;
scheme_extension_table->scheme_make_folding_closed_prim = scheme_make_folding_closed_prim;
scheme_extension_table->scheme_make_prim_w_everything = scheme_make_prim_w_everything;
scheme_extension_table->scheme_make_closed_prim_w_everything = scheme_make_closed_prim_w_everything;
scheme_extension_table->scheme_prim_is_method = scheme_prim_is_method;
scheme_extension_table->scheme_make_pair = scheme_make_pair;

14
src/mzscheme/src/schemexm.h
View File

@ -124,10 +124,10 @@
#define scheme_eval_string (scheme_extension_table->scheme_eval_string)
#define scheme_eval_string_multi (scheme_extension_table->scheme_eval_string_multi)
#define scheme_eval_string_all (scheme_extension_table->scheme_eval_string_all)
#define _scheme_apply_known_closed_prim (scheme_extension_table->_scheme_apply_known_closed_prim)
#define _scheme_apply_known_closed_prim_multi (scheme_extension_table->_scheme_apply_known_closed_prim_multi)
#define _scheme_apply_closed_prim (scheme_extension_table->_scheme_apply_closed_prim)
#define _scheme_apply_closed_prim_multi (scheme_extension_table->_scheme_apply_closed_prim_multi)
#define _scheme_apply_known_prim_closure (scheme_extension_table->_scheme_apply_known_prim_closure)
#define _scheme_apply_known_prim_closure_multi (scheme_extension_table->_scheme_apply_known_prim_closure_multi)
#define _scheme_apply_prim_closure (scheme_extension_table->_scheme_apply_prim_closure)
#define _scheme_apply_prim_closure_multi (scheme_extension_table->_scheme_apply_prim_closure_multi)
#define scheme_values (scheme_extension_table->scheme_values)
#define scheme_check_one_value (scheme_extension_table->scheme_check_one_value)
#define scheme_tail_apply (scheme_extension_table->scheme_tail_apply)
@ -209,14 +209,16 @@
#define scheme_clone_hash_table (scheme_extension_table->scheme_clone_hash_table)
#define scheme_make_prim (scheme_extension_table->scheme_make_prim)
#define scheme_make_noneternal_prim (scheme_extension_table->scheme_make_noneternal_prim)
#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
#define scheme_make_prim_w_arity (scheme_extension_table->scheme_make_prim_w_arity)
#define scheme_make_folding_prim (scheme_extension_table->scheme_make_folding_prim)
#define scheme_make_noncm_prim (scheme_extension_table->scheme_make_noncm_prim)
#define scheme_make_noneternal_prim_w_arity (scheme_extension_table->scheme_make_noneternal_prim_w_arity)
#define scheme_make_prim_w_everything (scheme_extension_table->scheme_make_prim_w_everything)
#define scheme_make_prim_closure_w_arity (scheme_extension_table->scheme_make_prim_closure_w_arity)
#define scheme_make_folding_prim_closure (scheme_extension_table->scheme_make_folding_prim_closure)
#define scheme_make_closed_prim (scheme_extension_table->scheme_make_closed_prim)
#define scheme_make_closed_prim_w_arity (scheme_extension_table->scheme_make_closed_prim_w_arity)
#define scheme_make_folding_closed_prim (scheme_extension_table->scheme_make_folding_closed_prim)
#define scheme_make_prim_w_everything (scheme_extension_table->scheme_make_prim_w_everything)
#define scheme_make_closed_prim_w_everything (scheme_extension_table->scheme_make_closed_prim_w_everything)
#define scheme_prim_is_method (scheme_extension_table->scheme_prim_is_method)
#define scheme_make_pair (scheme_extension_table->scheme_make_pair)

35
src/mzscheme/src/schnapp.inc
View File

@ -5,41 +5,18 @@
if (t == scheme_prim_type) {
Scheme_Object *v;
Scheme_Primitive_Proc *prim;
GC_CAN_IGNORE Scheme_Primitive_Proc *prim;
GC_CAN_IGNORE Scheme_Primitive_Closure_Proc *f;
prim = (Scheme_Primitive_Proc *)rator;
if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
if (argc < prim->mina || (argc > prim->mu.maxa && prim->mina >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->mu.maxa, argc, argv);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(argc, argv);
#if PRIM_CHECK_VALUE
v = _scheme_force_value(v);
#endif
#if PRIM_CHECK_MULTI
if (v == SCHEME_MULTIPLE_VALUES) {
scheme_wrong_return_arity(NULL, 1, scheme_multiple_count, scheme_multiple_array, NULL);
return NULL; /* Shouldn't get here */
}
#endif
return v;
} else if (t == scheme_closed_prim_type) {
Scheme_Object *v;
Scheme_Closed_Primitive_Proc *prim;
prim = (Scheme_Closed_Primitive_Proc *)rator;
if (argc < prim->mina || (argc > prim->maxa && prim->maxa >= 0)) {
scheme_wrong_count(prim->name, prim->mina, prim->maxa, argc, argv);
return NULL; /* Shouldn't get here */
}
v = prim->prim_val(prim->data, argc, argv);
f = (Scheme_Primitive_Closure_Proc *)prim->prim_val;
v = f(argc, argv, (Scheme_Object *)prim);
#if PRIM_CHECK_VALUE
v = _scheme_force_value(v);

4
src/mzscheme/src/schvers.h
View File

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 301
#define MZSCHEME_VERSION_MINOR 6
#define MZSCHEME_VERSION_MINOR 7
#define MZSCHEME_VERSION "301.6" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "301.7" _MZ_SPECIAL_TAG

113
src/mzscheme/src/struct.c
View File

@ -565,9 +565,10 @@ static Scheme_Object *current_code_inspector(int argc, Scheme_Object *argv[])
/* properties */
/*========================================================================*/
static Scheme_Object *prop_pred(Scheme_Object *prop, int argc, Scheme_Object **args)
static Scheme_Object *prop_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
{
Scheme_Struct_Type *stype;
Scheme_Object *prop = SCHEME_PRIM_CLOSURE_ELS(prim)[0];
if (SCHEME_STRUCTP(args[0]))
stype = ((Scheme_Structure *)args[0])->stype;
@ -590,14 +591,14 @@ static Scheme_Object *prop_pred(Scheme_Object *prop, int argc, Scheme_Object **a
return scheme_false;
}
static Scheme_Object *prop_accessor(Scheme_Object *prop, int argc, Scheme_Object **args)
static Scheme_Object *do_prop_accessor(Scheme_Object *prop, Scheme_Object *arg, int error_ok)
{
Scheme_Struct_Type *stype;
if (SCHEME_STRUCTP(args[0]))
stype = ((Scheme_Structure *)args[0])->stype;
else if (SAME_TYPE(SCHEME_TYPE(args[0]), scheme_struct_type_type))
stype = (Scheme_Struct_Type *)args[0];
if (SCHEME_STRUCTP(arg))
stype = ((Scheme_Structure *)arg)->stype;
else if (SAME_TYPE(SCHEME_TYPE(arg), scheme_struct_type_type))
stype = (Scheme_Struct_Type *)arg;
else
stype = NULL;
@ -616,13 +617,18 @@ static Scheme_Object *prop_accessor(Scheme_Object *prop, int argc, Scheme_Object
}
}
if (argc < 2) /* hack; see scheme_struct_type_property_ref */
if (error_ok) /* hack; see scheme_struct_type_property_ref */
scheme_wrong_type("property accessor",
"struct or struct-type with property",
0, argc, args);
0, 1, (Scheme_Object **)&arg);
return NULL;
}
static Scheme_Object *prop_accessor(int argc, Scheme_Object **args, Scheme_Object *prim)
{
return do_prop_accessor(SCHEME_PRIM_CLOSURE_ELS(prim)[0], args[0], 1);
}
static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
{
Scheme_Struct_Property *p;
@ -652,20 +658,20 @@ static Scheme_Object *make_struct_type_property(int argc, Scheme_Object *argv[])
name[len] = '?';
name[len+1] = 0;
v = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)prop_pred,
(void *)p,
name,
1, 1, 0);
v = scheme_make_folding_prim_closure(prop_pred,
1, a,
name,
1, 1, 0);
a[1] = v;
name = MALLOC_N_ATOMIC(char, len + 10);
memcpy(name, SCHEME_SYM_VAL(argv[0]), len);
memcpy(name + len, "-accessor", 10);
v = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)prop_accessor,
(void *)p,
name,
1, 1, 0);
v = scheme_make_folding_prim_closure(prop_accessor,
1, a,
name,
1, 1, 0);
a[2] = v;
return scheme_values(3, a);
@ -690,7 +696,7 @@ Scheme_Object *scheme_make_struct_type_property(Scheme_Object *name)
Scheme_Object *scheme_struct_type_property_ref(Scheme_Object *prop, Scheme_Object *s)
{
return prop_accessor(prop, 2, &s); /* 2 is a hack! */
return do_prop_accessor(prop, s, 0);
}
static Scheme_Object *struct_type_property_p(int argc, Scheme_Object *argv[])
@ -978,13 +984,20 @@ scheme_make_struct_instance(Scheme_Object *_stype, int argc, Scheme_Object **arg
return (Scheme_Object *)inst;
}
static Scheme_Object *struct_pred(Scheme_Struct_Type *stype, int argc, Scheme_Object **args)
static Scheme_Object *
make_struct_instance(int argc, Scheme_Object **args, Scheme_Object *prim)
{
if (SCHEME_STRUCTP(args[0])
&& STRUCT_TYPEP(stype, ((Scheme_Structure *)args[0])))
return scheme_true;
else
return scheme_false;
return scheme_make_struct_instance(SCHEME_PRIM_CLOSURE_ELS(prim)[0], argc, args);
}
static Scheme_Object *struct_pred(int argc, Scheme_Object **args, Scheme_Object *prim)
{
if (SCHEME_STRUCTP(args[0])) {
Scheme_Struct_Type *stype = (Scheme_Struct_Type *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
if (STRUCT_TYPEP(stype, ((Scheme_Structure *)args[0])))
return scheme_true;
}
return scheme_false;
}
static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args, int argc)
@ -1041,10 +1054,11 @@ static int parse_pos(const char *who, Struct_Proc_Info *i, Scheme_Object **args,
return pos;
}
static Scheme_Object *struct_getter(Struct_Proc_Info *i, int argc, Scheme_Object **args)
static Scheme_Object *struct_getter(int argc, Scheme_Object **args, Scheme_Object *prim)
{
Scheme_Structure *inst;
int pos;
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
inst = (Scheme_Structure *)args[0];
@ -1069,11 +1083,12 @@ static Scheme_Object *struct_getter(Struct_Proc_Info *i, int argc, Scheme_Object
return inst->slots[pos];
}
static Scheme_Object *struct_setter(Struct_Proc_Info *i, int argc, Scheme_Object **args)
static Scheme_Object *struct_setter(int argc, Scheme_Object **args, Scheme_Object *prim)
{
Scheme_Structure *inst;
int pos;
Scheme_Object *v;
Struct_Proc_Info *i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(prim)[0];
if (!SCHEME_STRUCTP(args[0])) {
scheme_wrong_type(i->func_name,
@ -1426,7 +1441,7 @@ int scheme_inspector_sees_part(Scheme_Object *s, Scheme_Object *insp, int pos)
#define STRUCT_PROCP(o, t) \
(SCHEME_STRUCT_PROCP(o) && (((Scheme_Closed_Primitive_Proc *)o)->pp.flags & t))
(SCHEME_STRUCT_PROCP(o) && (((Scheme_Primitive_Proc *)o)->pp.flags & t))
static Scheme_Object *
struct_setter_p(int argc, Scheme_Object *argv[])
@ -1469,7 +1484,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
if (!STRUCT_PROCP(argv[0], (getter
? SCHEME_PRIM_IS_STRUCT_GETTER
: SCHEME_PRIM_IS_STRUCT_SETTER))
|| (((Scheme_Closed_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) {
|| (((Scheme_Primitive_Proc *)argv[0])->mina == (getter ? 1 : 2))) {
scheme_wrong_type(who, (getter
? "accessor procedure that requires a field index"
: "mutator procedure that requires a field index"),
@ -1477,7 +1492,7 @@ static Scheme_Object *make_struct_field_xxor(const char *who, int getter,
return NULL;
}
i = (Struct_Proc_Info *)((Scheme_Closed_Primitive_Proc *)argv[0])->data;
i = (Struct_Proc_Info *)SCHEME_PRIM_CLOSURE_ELS(argv[0])[0];
pos = parse_pos(who, i, argv, argc);
@ -1930,22 +1945,24 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
char *func_name,
Scheme_ProcT proc_type, int field_num)
{
Scheme_Object *p;
Scheme_Object *p, *a[1];
short flags = SCHEME_PRIM_IS_STRUCT_PROC;
if (proc_type == SCHEME_CONSTR) {
p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)scheme_make_struct_instance,
(void *)struct_type,
func_name,
struct_type->num_islots,
struct_type->num_islots,
0);
a[0] = (Scheme_Object *)struct_type;
p = scheme_make_folding_prim_closure(make_struct_instance,
1, a,
func_name,
struct_type->num_islots,
struct_type->num_islots,
0);
flags |= SCHEME_PRIM_IS_STRUCT_CONSTR;
} else if (proc_type == SCHEME_PRED) {
p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_pred,
(void *)struct_type,
func_name,
1, 1, 1);
a[0] = (Scheme_Object *)struct_type;
p = scheme_make_folding_prim_closure(struct_pred,
1, a,
func_name,
1, 1, 1);
flags |= SCHEME_PRIM_IS_STRUCT_PRED;
} else {
Struct_Proc_Info *i;
@ -1965,20 +1982,22 @@ make_struct_proc(Scheme_Struct_Type *struct_type,
else
need_pos = 0;
a[0] = (Scheme_Object *)i;
if ((proc_type == SCHEME_GETTER) || (proc_type == SCHEME_GEN_GETTER)) {
p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_getter,
(void *)i,
func_name,
1 + need_pos, 1 + need_pos, 1);
p = scheme_make_folding_prim_closure(struct_getter,
1, a,
func_name,
1 + need_pos, 1 + need_pos, 1);
flags |= SCHEME_PRIM_IS_STRUCT_GETTER;
/* Cache the accessor only if `struct_info' is used.
This avoids keep lots of useless accessors.
if (need_pos) struct_type->accessor = p; */
} else {
p = scheme_make_folding_closed_prim((Scheme_Closed_Prim *)struct_setter,
(void *)i,
func_name,
2 + need_pos, 2 + need_pos, 0);
p = scheme_make_folding_prim_closure(struct_setter,
1, a,
func_name,
2 + need_pos, 2 + need_pos, 0);
flags |= SCHEME_PRIM_IS_STRUCT_SETTER;
/* See note above:
if (need_pos) struct_type->mutator = p; */

2
src/mzscheme/src/thread.c
View File

@ -5714,7 +5714,7 @@ static Scheme_Object *extend_parameterization(int argc, Scheme_Object *argv[])
a[1] = scheme_false;
if (SCHEME_PRIMP(argv[i])) {
Scheme_Prim *proc;
proc = ((Scheme_Primitive_Proc *)argv[i])->prim_val;
proc = (Scheme_Prim *)((Scheme_Primitive_Proc *)argv[i])->prim_val;
key = proc(2, a); /* leads to scheme_param_config to set a[1] */
} else {
/* sets a[1] */

2
src/mzscheme/utils/xcglue.h
View File

@ -158,7 +158,7 @@ mzchar objscheme_unbundle_char(Scheme_Object *, const char *);
#define objscheme_unbundle_long objscheme_unbundle_integer
#define objscheme_unbundle_int objscheme_unbundle_integer
#define OBJSCHEME_PRIM_METHOD(m, cf) (SCHEME_PRIMP(m) && (((Scheme_Primitive_Proc *)m)->prim_val == cf))
#define OBJSCHEME_PRIM_METHOD(m, cf) (SCHEME_PRIMP(m) && ((Scheme_Prim *)((Scheme_Primitive_Proc *)m)->prim_val == cf))
#define COPY_JMPBUF(dest, src) memcpy(&dest, &src, sizeof(mz_jmp_buf));