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

359.3

Browse Source 
svn: r5219
This commit is contained in:
Matthew Flatt 2007-01-04 11:14:58 +00:00
parent 32af18a5a9
commit 6b60d57a86
44 changed files with 6535 additions and 5361 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

90
collects/mred/private/lock.ss
View File

@ -37,57 +37,69 @@
(define old-paramz #f)
(define old-break-paramz #f)
(define exited-key (gensym 'as-exit))
(define lock-tag (make-continuation-prompt-tag 'lock))
(define (as-entry f)
(cond
[(eq? monitor-owner (current-thread))
(f)]
[else
((let/ec k
(dynamic-wind
(lambda ()
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread)))
(lambda ()
(set! old-paramz (current-parameterization))
(set! old-break-paramz (current-break-parameterization))
(parameterize ([error-value->string-handler entered-err-string-handler])
(with-handlers ([void (lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(k (lambda () (raise exn))))])
(with-continuation-mark
exited-key
#f
(call-with-continuation-prompt
(lambda ()
(dynamic-wind
(lambda ()
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread)))
(lambda ()
(set! old-paramz (current-parameterization))
(set! old-break-paramz (current-break-parameterization))
(parameterize ([error-value->string-handler entered-err-string-handler])
(parameterize-break
#f
(call-with-values
f
(lambda args (lambda () (apply values args))))))))
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f)))))]))
; entry-point macros in macros.ss
(call-with-exception-handler
(lambda (exn)
;; Get out of atomic region before letting
;; an exception handler work
(if (continuation-mark-set-first #f exited-key)
exn ; defer to previous exn handler
(abort-current-continuation
lock-tag
(lambda () (raise exn)))))
f))))
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f))))
lock-tag))]))
(define (as-exit f)
;; (unless (eq? monitor-owner (current-thread)) (error 'monitor-exit "not in monitored area"))
(let ([paramz old-paramz]
[break-paramz old-break-paramz])
(call-with-parameterization
paramz
(lambda ()
(call-with-break-parameterization
break-paramz
(lambda ()
(dynamic-wind
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f))
f
(lambda ()
(set! old-paramz paramz)
(set! old-break-paramz break-paramz)
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread))))))))))
(with-continuation-mark
exited-key
#t ; disables special exception handling
(call-with-parameterization
paramz
(lambda ()
(call-with-break-parameterization
break-paramz
(lambda ()
(dynamic-wind
(lambda ()
(set! monitor-owner #f)
(semaphore-post monitor-sema)
(wx:in-atomic-region #f))
f
(lambda ()
(set! old-paramz paramz)
(set! old-break-paramz break-paramz)
(wx:in-atomic-region monitor-sema)
(set! monitor-owner (current-thread)))))))))))
(define-syntax entry-point
(lambda (stx)

91
collects/tests/mzscheme/basic.ss
View File

@ -1395,6 +1395,85 @@
(test #f list-length '(a b . c))
(test '() map cadr '())
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;; exceptions
(test 10 'exns
(with-handlers ([integer? (lambda (x) 10)])
(raise 12)))
(test '(apple) 'exns
(with-handlers ([void (lambda (x) (list x))])
(with-handlers ([integer? (lambda (x) 10)])
(raise 'apple))))
(test '((10)) 'exns
(with-handlers ([void (lambda (x) (list x))])
(with-handlers ([integer? (lambda (x) (raise (list x)))])
(raise 10))))
(test '((10)) 'exns
(let/ec esc
(parameterize ([uncaught-exception-handler (lambda (x) (esc (list x)))])
(with-handlers ([integer? (lambda (x) (raise (list x)))])
(raise 10)))))
(test '#((10)) 'exns
(let/ec esc
(with-handlers ([void (lambda (x) (vector x))])
(parameterize ([uncaught-exception-handler (lambda (x) (esc (list x)))])
(with-handlers ([integer? (lambda (x) (raise (list x)))])
(raise 10))))))
(test '(except) 'escape
(let/ec k
(call-with-exception-handler
(lambda (exn)
(k (list exn)))
(lambda () (raise 'except)))))
(test '#&except 'escape
(let/ec k
(call-with-exception-handler
(lambda (exn)
(k (list exn)))
(lambda ()
(call-with-exception-handler
(lambda (exn)
(k (box exn)))
(lambda ()
(raise 'except)))))))
(test '#(except) 'escape
(with-handlers ([void (lambda (x) x)])
(values
(call-with-exception-handler
(lambda (exn)
(vector exn))
(lambda ()
(raise 'except))))))
(test '(except) 'escape
(with-handlers ([void (lambda (x) x)])
(values
(call-with-exception-handler
(lambda (exn)
(vector exn))
(lambda ()
(call-with-exception-handler
(lambda (exn)
(list exn))
(lambda ()
(raise 'except))))))))
(test '#((except)) 'escape
(with-handlers ([void (lambda (x) x)])
(values
(call-with-exception-handler
(lambda (exn)
(vector exn))
(lambda ()
(values
(call-with-exception-handler
(lambda (exn)
(list exn))
(lambda ()
(raise 'except)))))))))
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
;;; This tests full conformance of call-with-current-continuation. It
;;; is a separate test because some schemes do not support call/cc
;;; other than escape procedures. I am indebted to
@ -1727,6 +1806,18 @@
(try 3 5)
(try 10 5))
;; Make sure let doesn't allocate a mutatble cell too early:
(test 2 'let+call/cc
(let ([count 0])
(let ([first-time? #t]
[k (call/cc values)])
(if first-time?
(begin
(set! first-time? #f)
(set! count (+ count 1))
(k values))))
count))
(arity-test call/cc 1 2)
(arity-test call/ec 1 1)
(err/rt-test (call/cc 4))

9
doc/release-notes/mzscheme/HISTORY
View File

@ -1,3 +1,7 @@
Version 369.3
Adjusted exception-handler calling to propagate any returned value
to the previous exception handler
Version 369.2
Removed current-exception-handler and initial-exception-handler
Added uncaught-exception-handler
@ -11,6 +15,11 @@ Changed top-level begin to insert a prompt around each sub-expression
Added #%top-interaction and #%expression
Added prop:input-port and prop:output-port
Changed char-whitespace? to produce #t for #\u0085
Inside MzScheme: use
SCHEME_INPUT_PORTP() instead of SCHEME_INPORTP()
SCHEME_OUTPUT_PORTP() instead of SCHEME_OUTPORTP()
scheme_input_port_record() instead of casting to Scheme_Input_Port*
scheme_output_port_record() instead of casting to Scheme_Output_Port*
Version 369.1
Changed dyanmic-require to expand requests for exported syntax

6
src/README
View File

@ -50,9 +50,9 @@ the Unix instructions below, but note the following:
bundle MrEd.app that goes into the `plt' directory. Installation
creates a script, plt/bin/mred, that runs the bundle.
* The --enable-shared flag for `configure' is redundant (i.e., builds
create and use frameworks by default), and --disable-shared is not
supported.
* The --enable-shared flag for `configure' should not be used,
because builds create and use frameworks by default. Furthermore,
--disable-shared is not supported.
* To build an X11-based MrEd, run `configure' with the --enable-xonx
flag. Frameworks are not used for such builds. The --enable-xonx

12
src/configure vendored
View File

@ -1564,6 +1564,9 @@ fi
if test "${enable_dynlib}" = "no" ; then
enable_shared=no
fi
if test "${enable_dynlib}" = "yes" ; then
enable_shared=yes
fi
if test "${enable_shared}" != "yes" ; then
enable_lt=no
fi
@ -1574,6 +1577,13 @@ if test "${enable_lt}" = "yes" ; then
exit 1
fi
if test "${enable_shared}" = "yes" ; then
if test "$OS" = "Darwin" ; then
echo "ERROR: don't use --enable-shared or --enable-dynlib under Mac OS X"
exit 1
fi
fi
enable_quartz=no
if test "${enable_xonx}" = "yes" ; then
enable_quartz=no
@ -5345,6 +5355,7 @@ case $OS in
;;
FreeBSD)
LIBS="$LIBS -rdynamic"
DYN_CFLAGS="-fPIC"
;;
OpenBSD)
LIBS="$LIBS -rdynamic"
@ -5456,7 +5467,6 @@ case $OS in
DYN_CFLAGS=""
enable_xrender=no
enable_cairo=no
enable_shared=no
enable_gl=no
enable_pthread=no
if test "${enable_libfw}" = "yes" ; then

2
src/mac/cw/MrEd.r
View File

@ -10,7 +10,7 @@ data 'DITL' (129) {
$"0081 0000 0000 0018 008F 0048 0170 8844" /* .<2E>.......<EFBFBD>.H.pˆD */
$"4372 6561 7465 6420 7769 7468 2050 4C54" /* Created with PLT */
$"2053 6368 656D 650D A920 3230 3034 2D32" /* Scheme.© 2004-2 */
$"3030 3620 504C 5420 5363 6865 6D65 2049" /* 006 PLT Scheme I */
$"3030 3720 504C 5420 5363 6865 6D65 2049" /* 007 PLT Scheme I */
$"6E63 2E20 0DA9 2031 3939 352D 3230 3033" /* nc. .© 1995-2003 */
$"2050 4C54 0000 0000 004D 008F 0089 018F" /* PLT.....M.<EFBFBD>.‰.<EFBFBD> */
$"884E 466F 7220 7570 2D74 6F2D 6461 7465" /* ˆNFor up-to-date */

11
src/mzscheme/configure.ac
View File

@ -99,6 +99,9 @@ fi
if test "${enable_dynlib}" = "no" ; then
enable_shared=no
fi
if test "${enable_dynlib}" = "yes" ; then
enable_shared=yes
fi
if test "${enable_shared}" != "yes" ; then
enable_lt=no
fi
@ -109,6 +112,13 @@ if test "${enable_lt}" = "yes" ; then
exit 1
fi
if test "${enable_shared}" = "yes" ; then
if test "$OS" = "Darwin" ; then
echo "ERROR: don't use --enable-shared or --enable-dynlib under Mac OS X"
exit 1
fi
fi
enable_quartz=no
if test "${enable_xonx}" = "yes" ; then
enable_quartz=no
@ -591,7 +601,6 @@ case $OS in
DYN_CFLAGS=""
enable_xrender=no
enable_cairo=no
enable_shared=no
enable_gl=no
enable_pthread=no
if test "${enable_libfw}" = "yes" ; then

10
src/mzscheme/gc2/compact.c
View File

@ -2655,7 +2655,7 @@ void protect_old_mpages()
#if GENERATIONS
static void designate_modified(void *p)
static int designate_modified(void *p)
{
unsigned long g = ((unsigned long)p >> MAPS_SHIFT);
MPage *map;
@ -2675,7 +2675,7 @@ static void designate_modified(void *p)
if (page->flags & MFLAG_CONTINUED) {
designate_modified(page->o.bigblock_start);
num_seg_faults++;
return;
return 1;
} else if (page->age) {
page->flags |= MFLAG_MODIFIED;
p = (void *)((long)p & MPAGE_START);
@ -2684,12 +2684,12 @@ static void designate_modified(void *p)
else
protect_pages(p, MPAGE_SIZE, 1);
num_seg_faults++;
return;
return 1;
}
GCPRINT(GCOUTF, "Seg fault (internal error) at %lx [%ld]\n",
(long)p, num_seg_faults);
abort();
return 0;
}
}
@ -2700,7 +2700,7 @@ static void designate_modified(void *p)
#if defined(_WIN32) && defined(CHECKS)
DebugBreak();
#endif
abort();
return 0;
}
/* The platform-specific signal handlers, and initialization function: */

11
src/mzscheme/gc2/newgc.c
View File

@ -41,7 +41,6 @@
# define inline _inline
#endif
#if defined(sparc) || defined(__sparc) || defined(__sparc__)
# define ALIGN_DOUBLES
#endif
@ -175,7 +174,7 @@ inline static void free_used_pages(size_t len)
#if defined(__APPLE__) && defined(__MACH__)
# define TEST 0
void designate_modified(void *p);
int designate_modified(void *p);
# include "vm_osx.c"
# define MALLOCATOR_DEFINED
#endif
@ -1792,14 +1791,18 @@ int GC_set_account_hook(int type, void *c1, unsigned long b, void *c2)
static int generations_available = 1;
void designate_modified(void *p)
int designate_modified(void *p)
{
struct mpage *page = find_page(p);
if(page) {
protect_pages(page, page->size, 1);
page->back_pointers = 1;
} else GCERR((GCOUTF, "Seg fault (internal error) at %p\n", p));
return 1;
} else {
GCPRINT(GCOUTF, "Seg fault (internal error) at %p\n", p);
return 0;
}
}
#include "sighand.c"

19
src/mzscheme/gc2/sighand.c
View File

@ -16,7 +16,8 @@
# include <signal.h>
void fault_handler(int sn, struct siginfo *si, void *ctx)
{
designate_modified(si->si_addr);
if (!designate_modified(si->si_addr))
abort();
# define NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGSEGV
}
@ -27,7 +28,8 @@ void fault_handler(int sn, struct siginfo *si, void *ctx)
# include <signal.h>
void fault_handler(int sn, siginfo_t *si, void *ctx)
{
designate_modified(si->si_addr);
if (!designate_modified(si->si_addr))
abort();
}
# define NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGBUS
@ -38,7 +40,8 @@ void fault_handler(int sn, siginfo_t *si, void *ctx)
# include <signal.h>
void fault_handler(int sn, struct siginfo *si, void *ctx)
{
designate_modified(si->si_addr);
if (!designate_modified(si->si_addr))
abort();
}
# define NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGSEGV
@ -50,9 +53,10 @@ LONG WINAPI fault_handler(LPEXCEPTION_POINTERS e)
{
if ((e->ExceptionRecord->ExceptionCode == EXCEPTION_ACCESS_VIOLATION)
&& (e->ExceptionRecord->ExceptionInformation[0] == 1)) {
designate_modified((void *)e->ExceptionRecord->ExceptionInformation[1]);
return EXCEPTION_CONTINUE_EXECUTION;
if (designate_modified((void *)e->ExceptionRecord->ExceptionInformation[1]))
return EXCEPTION_CONTINUE_EXECUTION;
else
return EXCEPTION_CONTINUE_SEARCH;
} else
return EXCEPTION_CONTINUE_SEARCH;
}
@ -75,7 +79,8 @@ typedef LONG (WINAPI*gcPVECTORED_EXCEPTION_HANDLER)(LPEXCEPTION_POINTERS e);
# include <signal.h>
void fault_handler(int sn, siginfo_t *si, void *ctx)
{
designate_modified(si->si_addr);
if (!designate_modified(si->si_addr))
abort();
# define NEED_SIGACTION
# define USE_SIGACTON_SIGNAL_KIND SIGSEGV
}

16
src/mzscheme/gc2/vm_osx.c
View File

@ -37,7 +37,7 @@
#ifndef TEST
# define TEST 1
# include "my_qsort.c"
void designate_modified(void *p);
int designate_modified(void *p);
#endif
#ifdef __POWERPC__
@ -236,8 +236,10 @@ kern_return_t catch_exception_raise(mach_port_t port,
/* kernel return value is in exception_data[0], faulting address in
exception_data[1] */
if(exception_data[0] == KERN_PROTECTION_FAILURE) {
designate_modified((void*)exception_data[1]);
return KERN_SUCCESS;
if (designate_modified((void*)exception_data[1]))
return KERN_SUCCESS;
else
return KERN_FAILURE;
} else
#endif
return KERN_FAILURE;
@ -355,18 +357,18 @@ static void macosx_init_exception_handler()
char *normal_page = NULL;
char *big_page = NULL;
void designate_modified(void *p)
int designate_modified(void *p)
{
if((p >= normal_page) && (p < (normal_page + MPAGE_SIZE))) {
protect_pages(p, MPAGE_SIZE, 1);
return;
return 1;
}
if((p >= big_page) && (p < (big_page + BPAGE_SIZE))) {
protect_pages(p, BPAGE_SIZE, 1);
return;
return 1;
}
printf("Unrecognized write: %p\n", p);
abort();
return 0;
}
int main(int argc, char **argv)

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

@ -403,6 +403,7 @@ scheme_getdrive
scheme_split_path
scheme_build_path
scheme_path_to_directory_path
scheme_path_to_complete_path
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path

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

@ -410,6 +410,7 @@ scheme_getdrive
scheme_split_path
scheme_build_path
scheme_path_to_directory_path
scheme_path_to_complete_path
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path

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

@ -391,6 +391,7 @@ EXPORTS
scheme_split_path
scheme_build_path
scheme_path_to_directory_path
scheme_path_to_complete_path
scheme_make_path
scheme_make_sized_path
scheme_make_sized_offset_path

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

@ -1027,8 +1027,6 @@ typedef struct Scheme_Thread {
Scheme_Simple_Object *list_stack;
int list_stack_pos;
Scheme_Hash_Table *rn_memory;
/* MzScheme client can use: */
void (*on_kill)(struct Scheme_Thread *p);
void *kill_data;
@ -1171,6 +1169,9 @@ enum {
MZCONFIG_THREAD_SET,
MZCONFIG_THREAD_INIT_STACK_SIZE,
MZCONFIG_LOAD_DELAY_ENABLED,
MZCONFIG_DELAY_LOAD_INFO,
MZCONFIG_EXPAND_OBSERVE,
__MZCONFIG_BUILTIN_COUNT__

2
src/mzscheme/make-configure
View File

@ -8,7 +8,7 @@ echo "Creating $tgt from $src"
if [ -e "$tgt" ]; then
echo -n "overwriting $tgt, Ctrl-C to abort, enter to continue "; read R;
fi
autoconf "$src" | mzscheme -r "$0" > "$tgt"
autoconf "$src" | mzscheme -qr "$0" > "$tgt"
chmod +x "$tgt"
exit 0
|#

4
src/mzscheme/src/builtin.c
View File

@ -46,7 +46,9 @@ Scheme_Object *scheme_eval_compiled_sized_string_with_magic(const char *str, int
if (!env)
env = scheme_get_env(NULL);
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL, magic_sym, magic_val);
expr = scheme_internal_read(port, NULL, 1, 1, 0, 0, -1, NULL,
magic_sym, magic_val,
NULL);
if (multi_ok)
return _scheme_eval_compiled_multi(expr, env);

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

File diff suppressed because it is too large Load Diff

19
src/mzscheme/src/env.c
View File

@ -4228,7 +4228,7 @@ static Scheme_Object *read_local_unbox(Scheme_Object *obj)
static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
{
Resolve_Prefix *rp = (Resolve_Prefix *)obj;
Scheme_Object *tv, *sv;
Scheme_Object *tv, *sv, *ds;
int i;
i = rp->num_toplevels;
@ -4240,7 +4240,10 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
i = rp->num_stxes;
sv = scheme_make_vector(i, NULL);
while (i--) {
SCHEME_VEC_ELS(sv)[i] = rp->stxes[i];
ds = scheme_alloc_small_object();
ds->type = scheme_delay_syntax_type;
SCHEME_PTR_VAL(ds) = rp->stxes[i];
SCHEME_VEC_ELS(sv)[i] = ds;
}
return scheme_make_pair(scheme_make_integer(rp->num_lifts), scheme_make_pair(tv, sv));
@ -4249,7 +4252,7 @@ static Scheme_Object *write_resolve_prefix(Scheme_Object *obj)
static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
{
Resolve_Prefix *rp;
Scheme_Object *tv, *sv, **a;
Scheme_Object *tv, *sv, **a, *stx;
int i;
if (!SCHEME_PAIRP(obj)) return NULL;
@ -4279,7 +4282,15 @@ static Scheme_Object *read_resolve_prefix(Scheme_Object *obj)
i = rp->num_stxes;
a = MALLOC_N(Scheme_Object *, i);
while (i--) {
a[i] = SCHEME_VEC_ELS(sv)[i];
stx = SCHEME_VEC_ELS(sv)[i];
if (SCHEME_RPAIRP(stx)) {
rp->delay_info = (struct Scheme_Load_Delay *)SCHEME_CDR(stx);
rp->delay_refcount++;
stx = SCHEME_CAR(stx);
} else {
if (!SCHEME_STXP(stx)) return NULL;
}
a[i] = stx;
}
rp->stxes = a;

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

@ -63,7 +63,7 @@ static Scheme_Object *emergency_error_display_proc(int, Scheme_Object *[]);
static Scheme_Object *def_error_value_string_proc(int, Scheme_Object *[]);
static Scheme_Object *def_exit_handler_proc(int, Scheme_Object *[]);
static Scheme_Object *do_raise(Scheme_Object *arg, int return_ok, int need_debug);
static Scheme_Object *do_raise(Scheme_Object *arg, int need_debug);
static Scheme_Object *nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[]);
@ -606,8 +606,6 @@ scheme_inescapeable_error(const char *a, const char *b)
scheme_console_output(t, al + bl + 1);
}
#define RAISE_RETURNED "exception handler did not escape"
static void
call_error(char *buffer, int len, Scheme_Object *exn)
{
@ -1838,7 +1836,7 @@ static Scheme_Object *do_error(int for_user, int argc, Scheme_Object *argv[])
newargs[1] = TMP_CMARK_VALUE;
do_raise(scheme_make_struct_instance(exn_table[for_user ? MZEXN_FAIL_USER : MZEXN_FAIL].type,
2, newargs),
0, 1);
1);
return scheme_void;
#else
@ -2387,7 +2385,7 @@ scheme_raise_exn(int id, ...)
do_raise(scheme_make_struct_instance(exn_table[id].type,
c, eargs),
0, 1);
1);
#else
call_error(buffer, alen, scheme_false);
#endif
@ -2439,22 +2437,30 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
{
Scheme_Object *arg = argv[0], *orig_arg = SCHEME_CDR((Scheme_Object *)old_exn);
long len, mlen = -1, orig_mlen = -1, blen;
char *buffer, *msg, *orig_msg, *raisetype, *orig_raisetype, *who;
char *buffer, *msg, *orig_msg, *raisetype, *orig_raisetype, *who, *sep;
buffer = init_buf(&len, &blen);
who = SCHEME_BYTE_STR_VAL(SCHEME_CAR((Scheme_Object *)old_exn));
if (SCHEME_STRUCTP(arg)
&& scheme_is_struct_instance(exn_table[MZEXN].type, arg)) {
Scheme_Object *str = ((Scheme_Structure *)arg)->slots[0];
raisetype = "exception raised";
str = scheme_char_string_to_byte_string(str);
msg = SCHEME_BYTE_STR_VAL(str);
mlen = SCHEME_BYTE_STRLEN_VAL(str);
if (SCHEME_FALSEP(SCHEME_CAR((Scheme_Object *)old_exn))) {
raisetype = "";
sep = "";
who = "handler for uncaught exceptions";
msg = "did not escape";
} else {
msg = error_write_to_string_w_max(arg, len, NULL);
raisetype = "raise called (with non-exception value)";
who = SCHEME_BYTE_STR_VAL(SCHEME_CAR((Scheme_Object *)old_exn));
sep = " by ";
if (SCHEME_STRUCTP(arg)
&& scheme_is_struct_instance(exn_table[MZEXN].type, arg)) {
Scheme_Object *str = ((Scheme_Structure *)arg)->slots[0];
raisetype = "exception raised";
str = scheme_char_string_to_byte_string(str);
msg = SCHEME_BYTE_STR_VAL(str);
mlen = SCHEME_BYTE_STRLEN_VAL(str);
} else {
msg = error_write_to_string_w_max(arg, len, NULL);
raisetype = "raise called (with non-exception value)";
}
}
if (SCHEME_STRUCTP(orig_arg)
@ -2470,9 +2476,8 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
}
blen = scheme_sprintf(buffer, blen, "%s by %s: %t; original %s: %t",
raisetype,
who,
blen = scheme_sprintf(buffer, blen, "%s%s%s: %t; original %s: %t",
raisetype, sep, who,
msg, mlen,
orig_raisetype,
orig_msg, orig_mlen);
@ -2483,59 +2488,99 @@ nested_exn_handler(void *old_exn, int argc, Scheme_Object *argv[])
}
static Scheme_Object *
do_raise(Scheme_Object *arg, int return_ok, int need_debug)
do_raise(Scheme_Object *arg, int need_debug)
{
Scheme_Object *v, *p[1], *h;
Scheme_Cont_Frame_Data cframe, cframe2;
Scheme_Object *v, *p[1], *h, *marks;
Scheme_Cont_Mark_Chain *chain;
Scheme_Cont_Frame_Data cframe, cframe2;
if (scheme_current_thread->skip_error) {
scheme_longjmp (scheme_error_buf, 1);
}
/* In case we need to chain to the previous exception
handler, collect all marks. In the common case, getting the
marks will be cheap, because we just got them for
the exception record (and they're cached) or we're getting
them now for the exception record.
Continuation jumps into an exception handler are
disallowed, so we don't have to worry about the
context changing by the time an exception handler
returns. */
marks = scheme_current_continuation_marks(NULL);
chain = NULL;
if (need_debug) {
Scheme_Object *marks;
marks = scheme_current_continuation_marks(NULL);
((Scheme_Structure *)arg)->slots[1] = marks;
}
h = scheme_extract_one_cc_mark(NULL, scheme_exn_handler_key);
if (!h) {
h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
while (1) {
if (!h) {
h = scheme_get_param(scheme_current_config(), MZCONFIG_INIT_EXN_HANDLER);
marks = NULL;
}
v = scheme_make_byte_string_without_copying("exception handler");
v = scheme_make_closed_prim_w_arity(nested_exn_handler,
scheme_make_pair(v, arg),
"nested-exception-handler",
1, 1);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
p[0] = arg;
v = scheme_apply(h, 1, p);
scheme_pop_break_enable(&cframe2, 0);
scheme_pop_continuation_frame(&cframe);
/* Getting a value back means that we should chain to the
next exception handler; we supply the returned value to
the next exception handler (if any). */
if (marks) {
chain = ((Scheme_Cont_Mark_Set *)marks)->chain;
marks = NULL;
/* Init chain to position of the handler we just
called. */
while (chain->key != scheme_exn_handler_key) {
chain = chain->next;
}
}
if (chain) {
chain = chain->next;
while (chain && (chain->key != scheme_exn_handler_key)) {
chain = chain->next;
}
if (!chain)
h = NULL; /* use uncaught handler */
else
h = chain->val;
arg = v;
} else {
/* return from uncaught-exception handler */
p[0] = scheme_false;
return nested_exn_handler(scheme_make_pair(scheme_false, arg), 1, p);
}
}
v = scheme_make_byte_string_without_copying("exception handler");
v = scheme_make_closed_prim_w_arity(nested_exn_handler,
scheme_make_pair(v, arg),
"nested-exception-handler",
1, 1);
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_exn_handler_key, v);
scheme_push_break_enable(&cframe2, 0, 0);
p[0] = arg;
v = scheme_apply(h, 1, (Scheme_Object **)p);
scheme_pop_break_enable(&cframe2, 0);
scheme_pop_continuation_frame(&cframe);
if (return_ok)
return v;
call_error(RAISE_RETURNED, -1, scheme_false);
return scheme_void;
}
static Scheme_Object *
sch_raise(int argc, Scheme_Object *argv[])
{
return do_raise(argv[0], 0, 0);
return do_raise(argv[0], 0);
}
void scheme_raise(Scheme_Object *exn)
{
do_raise(exn, 0, 0);
do_raise(exn, 0);
}
typedef Scheme_Object (*Scheme_Struct_Field_Guard_Proc)(int argc, Scheme_Object *v);

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

@ -2831,7 +2831,7 @@ Scheme_Object *scheme_optimize_clone(int dup_ok, Scheme_Object *expr, Optimize_I
head2->iso.so.type = scheme_compiled_let_void_type;
head2->count = head->count;
head2->num_clauses = head->num_clauses;
SCHEME_LET_RECURSIVE(head2) = SCHEME_LET_RECURSIVE(head);
SCHEME_LET_FLAGS(head2) = SCHEME_LET_FLAGS(head);
/* Build let-value change: */
body = head->body;
@ -7020,8 +7020,7 @@ scheme_do_eval(Scheme_Object *obj, int num_rands, Scheme_Object **rands,
v = globs[i+p+1];
if (!v) {
v = globs[p];
v = scheme_add_rename(((Scheme_Object **)SCHEME_CDR(v))[i],
SCHEME_CAR(v));
v = scheme_delayed_rename((Scheme_Object **)v, i);
globs[i+p+1] = v;
}
@ -7266,7 +7265,7 @@ Scheme_Object *scheme_load_compiled_stx_string(const char *str, long len)
port = scheme_make_sized_byte_string_input_port(str, -len);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL);
expr = scheme_internal_read(port, NULL, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
expr = _scheme_eval_compiled(expr, scheme_get_env(NULL));
@ -8068,10 +8067,13 @@ Scheme_Object **scheme_push_prefix(Scheme_Env *genv, Resolve_Prefix *rp,
i = rp->num_toplevels;
v = scheme_stx_phase_shift_as_rename(now_phase - src_phase, src_modidx, now_modidx,
genv ? genv->export_registry : NULL);
if (v) {
if (v || rp->delay_info) {
/* Put lazy-shift info in a[i]: */
v = scheme_make_raw_pair(v, (Scheme_Object *)rp->stxes);
a[i] = v;
Scheme_Object **ls;
ls = MALLOC_N(Scheme_Object *, 2);
ls[0] = v;
ls[1] = (Scheme_Object *)rp;
a[i] = (Scheme_Object *)ls;
/* Rest of a left zeroed, to be filled in lazily by quote-syntax evaluation */
} else {
/* No shift, so fill in stxes immediately */
@ -8563,7 +8565,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
case scheme_let_value_type:
{
Scheme_Let_Value *lv = (Scheme_Let_Value *)expr;
Scheme_Object *rhs;
int q, p, c, i;
scheme_validate_expr(port, lv->value, stack, ht, tls, depth, letlimit, delta, num_toplevels, num_stxes, num_lifts,
@ -8584,18 +8585,6 @@ void scheme_validate_expr(Mz_CPort *port, Scheme_Object *expr,
if (!SCHEME_LET_AUTOBOX(lv)) {
stack[p] = VALID_VAL;
/* Check for wrappers on the RHS that box the `i'th result: */
for (rhs = lv->value;
SAME_TYPE(SCHEME_TYPE(rhs), scheme_syntax_type) && (SCHEME_PINT_VAL(rhs) == BOXVAL_EXPD);
rhs = SCHEME_CDDR((Scheme_Object *)SCHEME_IPTR_VAL(rhs))) {
int j = SCHEME_INT_VAL(SCHEME_CAR((Scheme_Object *)SCHEME_IPTR_VAL(rhs)));
if (j == i) {
stack[p] = VALID_BOX;
break;
}
}
}
}

8
src/mzscheme/src/file.c
View File

@ -3423,6 +3423,14 @@ static Scheme_Object *path_to_complete_path(int argc, Scheme_Object **argv)
return p;
}
Scheme_Object *scheme_path_to_complete_path(Scheme_Object *path, Scheme_Object *relto_path)
{
Scheme_Object *a[2];
a[0] = path;
a[1] = relto_path;
return path_to_complete_path(relto_path ? 2 : 1, a);
}
#ifndef NO_FILE_SYSTEM_UTILS
static char *filename_for_error(Scheme_Object *p)

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

@ -515,30 +515,6 @@ Scheme_Object *scheme_make_native_case_closure(Scheme_Native_Closure_Data *code)
return do_make_native_closure(code, -(code->closure_size + 1));
}
static void box_multiple_array_element(int pos)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object **naya, **a;
int i;
a = p->ku.multiple.array;
if (SAME_OBJ(a, p->values_buffer))
p->values_buffer = NULL;
naya = MALLOC_N(Scheme_Object *, p->ku.multiple.count);
for (i = p->ku.multiple.count; i--; ) {
naya[i] = a[i];
}
{
Scheme_Object *eb;
eb = scheme_make_envunbox(naya[pos]);
naya[pos] = eb;
}
p->ku.multiple.array = naya;
}
static void call_set_global_bucket(Scheme_Bucket *b, Scheme_Object *val, int set_undef)
{
scheme_set_global_bucket("set!", b, val, set_undef);
@ -4096,74 +4072,6 @@ static int generate(Scheme_Object *obj, mz_jit_state *jitter, int is_tail, int m
END_JIT_DATA(8);
}
break;
case BOXVAL_EXPD:
{
Scheme_Object *p, *v;
int pos, cnt;
START_JIT_DATA();
LOG_IT(("boxval\n"));
p = (Scheme_Object *)SCHEME_IPTR_VAL(obj);
v = SCHEME_CAR(p);
pos = SCHEME_INT_VAL(v);
p = SCHEME_CDR(p);
v = SCHEME_CAR(p);
cnt = SCHEME_INT_VAL(v);
p = SCHEME_CDR(p);
/* cnt is expected number of returns, and it will be
consistent with multi_ok; do something only if the actual
count is the same as cnt */
generate_non_tail(p, jitter, cnt != 1, 1);
CHECK_LIMIT();
JIT_UPDATE_THREAD_RSPTR_IF_NEEDED();
if (cnt != 1) {
jit_insn *ref, *ref2, *ref3;
__START_SHORT_JUMPS__(1);
ref = jit_bnei_p(jit_forward(), JIT_R0, SCHEME_MULTIPLE_VALUES);
/* Handle multiple values: */
jit_ldi_p(JIT_R2, &scheme_current_thread);
jit_ldxi_l(JIT_R1, JIT_R2, &((Scheme_Thread *)0x0)->ku.multiple.count);
ref3 = jit_bnei_p(jit_forward(), JIT_R1, cnt);
CHECK_LIMIT();
/* Received results match expected results */
(void)jit_movi_i(JIT_R0, pos);
mz_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(box_multiple_array_element);
CHECK_LIMIT();
(void)jit_movi_p(JIT_R0, SCHEME_MULTIPLE_VALUES);
/* Jump over single-value handling: */
ref2 = jit_jmpi(jit_forward());
CHECK_LIMIT();
/* Handle single value: */
mz_patch_branch(ref);
mz_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(scheme_make_envunbox);
CHECK_LIMIT();
jit_retval(JIT_R0);
mz_patch_ucbranch(ref2);
mz_patch_branch(ref3);
CHECK_LIMIT();
__END_SHORT_JUMPS__(1);
} else {
mz_prepare(1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(scheme_make_envunbox);
jit_retval(JIT_R0);
}
END_JIT_DATA(9);
}
break;
case SPLICE_EXPD:
{
scheme_signal_error("cannot JIT a top-level splice form");
@ -4831,23 +4739,20 @@ static int do_generate_common(mz_jit_state *jitter, void *_data)
/* Save global array: */
mz_set_local_p(JIT_V1, JIT_LOCAL3);
#endif
/* Compute i in JIT_V1: */
jit_subr_p(JIT_V1, JIT_R1, JIT_R2);
jit_subi_p(JIT_V1, JIT_V1, WORDS_TO_BYTES(1));
CHECK_LIMIT();
/* Load car & cdr of elements at p: */
jit_ldxi_p(JIT_R2, JIT_R0, &SCHEME_CAR((Scheme_Object *)0x0));
jit_ldxi_p(JIT_R0, JIT_R0, &SCHEME_CDR((Scheme_Object *)0x0));
jit_ldxr_p(JIT_R0, JIT_R0, JIT_V1);
/* Move R1 to V1 to save it: */
jit_movr_p(JIT_V1, JIT_R1);
/* Call scheme_add_rename: */
/* Compute i in JIT_R1: */
jit_subr_p(JIT_R1, JIT_R1, JIT_R2);
jit_subi_p(JIT_R1, JIT_R1, WORDS_TO_BYTES(1));
jit_rshi_ul(JIT_R1, JIT_R1, JIT_LOG_WORD_SIZE);
CHECK_LIMIT();
/* Call scheme_delayed_rename: */
JIT_UPDATE_THREAD_RSPTR();
CHECK_LIMIT();
mz_prepare(2);
jit_pusharg_p(JIT_R2);
jit_pusharg_l(JIT_R1);
jit_pusharg_p(JIT_R0);
(void)mz_finish(scheme_add_rename);
(void)mz_finish(scheme_delayed_rename);
CHECK_LIMIT();
jit_retval(JIT_R0);
/* Restore global array into JIT_R1, and put computed element at i+p+1: */

11
src/mzscheme/src/module.c
View File

@ -6122,6 +6122,11 @@ provide_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info *er
/* marshal/unmarshal */
/**********************************************************************/
XFORM_NONGCING static Scheme_Object *wrap_mod_stx(Scheme_Object *stx)
{
return (stx ? stx : scheme_false);
}
static Scheme_Object *write_module(Scheme_Object *obj)
{
Scheme_Module *m = (Scheme_Module *)obj;
@ -6192,9 +6197,9 @@ static Scheme_Object *write_module(Scheme_Object *obj)
l = cons(scheme_make_integer(m->max_let_depth), l);
l = cons(m->tt_rn_stx ? m->tt_rn_stx : scheme_false, l);
l = cons(m->et_rn_stx ? m->et_rn_stx : scheme_false, l);
l = cons(m->rn_stx ? m->rn_stx : scheme_false, l);
l = cons(wrap_mod_stx(m->tt_rn_stx), l);
l = cons(wrap_mod_stx(m->et_rn_stx), l);
l = cons(wrap_mod_stx(m->rn_stx), l);
l = cons(m->me->src_modidx, l);
l = cons(m->modname, l);

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

@ -1624,8 +1624,6 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->list_stack);
gcMARK(pr->rn_memory);
gcMARK(pr->kill_data);
gcMARK(pr->private_kill_data);
gcMARK(pr->private_kill_next);
@ -1713,8 +1711,6 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->list_stack);
gcFIXUP(pr->rn_memory);
gcFIXUP(pr->kill_data);
gcFIXUP(pr->private_kill_data);
gcFIXUP(pr->private_kill_next);
@ -2081,6 +2077,7 @@ static int resolve_prefix_val_MARK(void *p) {
Resolve_Prefix *rp = (Resolve_Prefix *)p;
gcMARK(rp->toplevels);
gcMARK(rp->stxes);
gcMARK(rp->delay_info);
return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2090,6 +2087,7 @@ static int resolve_prefix_val_FIXUP(void *p) {
Resolve_Prefix *rp = (Resolve_Prefix *)p;
gcFIXUP(rp->toplevels);
gcFIXUP(rp->stxes);
gcFIXUP(rp->delay_info);
return
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -2864,6 +2862,7 @@ static int mark_load_handler_data_MARK(void *p) {
gcMARK(d->p);
gcMARK(d->stxsrc);
gcMARK(d->expected_module);
gcMARK(d->delay_load_info);
return
gcBYTES_TO_WORDS(sizeof(LoadHandlerData));
@ -2877,6 +2876,7 @@ static int mark_load_handler_data_FIXUP(void *p) {
gcFIXUP(d->p);
gcFIXUP(d->stxsrc);
gcFIXUP(d->expected_module);
gcFIXUP(d->delay_load_info);
return
gcBYTES_TO_WORDS(sizeof(LoadHandlerData));
@ -3285,6 +3285,53 @@ static int mark_print_params_FIXUP(void *p) {
#define mark_print_params_IS_CONST_SIZE 1
static int mark_marshal_tables_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Marshal_Tables));
}
static int mark_marshal_tables_MARK(void *p) {
Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p;
gcMARK(mt->symtab);
gcMARK(mt->rns);
gcMARK(mt->rn_refs);
gcMARK(mt->st_refs);
gcMARK(mt->st_ref_stack);
gcMARK(mt->reverse_map);
gcMARK(mt->same_map);
gcMARK(mt->top_map);
gcMARK(mt->key_map);
gcMARK(mt->delay_map);
gcMARK(mt->rn_saved);
gcMARK(mt->shared_offsets);
gcMARK(mt->sorted_keys);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Marshal_Tables));
}
static int mark_marshal_tables_FIXUP(void *p) {
Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p;
gcFIXUP(mt->symtab);
gcFIXUP(mt->rns);
gcFIXUP(mt->rn_refs);
gcFIXUP(mt->st_refs);
gcFIXUP(mt->st_ref_stack);
gcFIXUP(mt->reverse_map);
gcFIXUP(mt->same_map);
gcFIXUP(mt->top_map);
gcFIXUP(mt->key_map);
gcFIXUP(mt->delay_map);
gcFIXUP(mt->rn_saved);
gcFIXUP(mt->shared_offsets);
gcFIXUP(mt->sorted_keys);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Marshal_Tables));
}
#define mark_marshal_tables_IS_ATOMIC 0
#define mark_marshal_tables_IS_CONST_SIZE 1
#endif /* PRINT */
/**********************************************************************/
@ -4248,10 +4295,13 @@ static int mark_cport_MARK(void *p) {
gcMARK(cp->start);
gcMARK(cp->orig_port);
gcMARK(cp->ht);
gcMARK(cp->ut);
gcMARK(cp->symtab);
gcMARK(cp->insp);
gcMARK(cp->magic_sym);
gcMARK(cp->magic_val);
gcMARK(cp->shared_offsets);
gcMARK(cp->delay_info);
return
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -4261,10 +4311,13 @@ static int mark_cport_FIXUP(void *p) {
gcFIXUP(cp->start);
gcFIXUP(cp->orig_port);
gcFIXUP(cp->ht);
gcFIXUP(cp->ut);
gcFIXUP(cp->symtab);
gcFIXUP(cp->insp);
gcFIXUP(cp->magic_sym);
gcFIXUP(cp->magic_val);
gcFIXUP(cp->shared_offsets);
gcFIXUP(cp->delay_info);
return
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -4312,6 +4365,7 @@ static int mark_read_params_MARK(void *p) {
gcMARK(rp->table);
gcMARK(rp->magic_sym);
gcMARK(rp->magic_val);
gcMARK(rp->delay_load_info);
return
gcBYTES_TO_WORDS(sizeof(ReadParams));
}
@ -4321,6 +4375,7 @@ static int mark_read_params_FIXUP(void *p) {
gcFIXUP(rp->table);
gcFIXUP(rp->magic_sym);
gcFIXUP(rp->magic_val);
gcFIXUP(rp->delay_load_info);
return
gcBYTES_TO_WORDS(sizeof(ReadParams));
}
@ -4329,6 +4384,64 @@ static int mark_read_params_FIXUP(void *p) {
#define mark_read_params_IS_CONST_SIZE 1
static int mark_delay_load_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Load_Delay));
}
static int mark_delay_load_MARK(void *p) {
Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p;
gcMARK(ld->path);
gcMARK(ld->symtab);
gcMARK(ld->shared_offsets);
gcMARK(ld->insp);
gcMARK(ld->rn_memory);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Load_Delay));
}
static int mark_delay_load_FIXUP(void *p) {
Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p;
gcFIXUP(ld->path);
gcFIXUP(ld->symtab);
gcFIXUP(ld->shared_offsets);
gcFIXUP(ld->insp);
gcFIXUP(ld->rn_memory);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Load_Delay));
}
#define mark_delay_load_IS_ATOMIC 0
#define mark_delay_load_IS_CONST_SIZE 1
static int mark_unmarshal_tables_SIZE(void *p) {
return
gcBYTES_TO_WORDS(sizeof(Scheme_Unmarshal_Tables));
}
static int mark_unmarshal_tables_MARK(void *p) {
Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p;
gcMARK(ut->rns);
gcMARK(ut->rp);
gcMARK(ut->decoded);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Unmarshal_Tables));
}
static int mark_unmarshal_tables_FIXUP(void *p) {
Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p;
gcFIXUP(ut->rns);
gcFIXUP(ut->rp);
gcFIXUP(ut->decoded);
return
gcBYTES_TO_WORDS(sizeof(Scheme_Unmarshal_Tables));
}
#define mark_unmarshal_tables_IS_ATOMIC 0
#define mark_unmarshal_tables_IS_CONST_SIZE 1
#endif /* READ */
/**********************************************************************/

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

@ -654,8 +654,6 @@ thread_val {
gcMARK(pr->list_stack);
gcMARK(pr->rn_memory);
gcMARK(pr->kill_data);
gcMARK(pr->private_kill_data);
gcMARK(pr->private_kill_next);
@ -814,6 +812,7 @@ resolve_prefix_val {
Resolve_Prefix *rp = (Resolve_Prefix *)p;
gcMARK(rp->toplevels);
gcMARK(rp->stxes);
gcMARK(rp->delay_info);
size:
gcBYTES_TO_WORDS(sizeof(Resolve_Prefix));
@ -1146,6 +1145,7 @@ mark_load_handler_data {
gcMARK(d->p);
gcMARK(d->stxsrc);
gcMARK(d->expected_module);
gcMARK(d->delay_load_info);
size:
gcBYTES_TO_WORDS(sizeof(LoadHandlerData));
@ -1316,6 +1316,26 @@ mark_print_params {
gcBYTES_TO_WORDS(sizeof(PrintParams));
}
mark_marshal_tables {
mark:
Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p;
gcMARK(mt->symtab);
gcMARK(mt->rns);
gcMARK(mt->rn_refs);
gcMARK(mt->st_refs);
gcMARK(mt->st_ref_stack);
gcMARK(mt->reverse_map);
gcMARK(mt->same_map);
gcMARK(mt->top_map);
gcMARK(mt->key_map);
gcMARK(mt->delay_map);
gcMARK(mt->rn_saved);
gcMARK(mt->shared_offsets);
gcMARK(mt->sorted_keys);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Marshal_Tables));
}
END print;
/**********************************************************************/
@ -1715,10 +1735,13 @@ mark_cport {
gcMARK(cp->start);
gcMARK(cp->orig_port);
gcMARK(cp->ht);
gcMARK(cp->ut);
gcMARK(cp->symtab);
gcMARK(cp->insp);
gcMARK(cp->magic_sym);
gcMARK(cp->magic_val);
gcMARK(cp->shared_offsets);
gcMARK(cp->delay_info);
size:
gcBYTES_TO_WORDS(sizeof(CPort));
}
@ -1740,10 +1763,33 @@ mark_read_params {
gcMARK(rp->table);
gcMARK(rp->magic_sym);
gcMARK(rp->magic_val);
gcMARK(rp->delay_load_info);
size:
gcBYTES_TO_WORDS(sizeof(ReadParams));
}
mark_delay_load {
mark:
Scheme_Load_Delay *ld = (Scheme_Load_Delay *)p;
gcMARK(ld->path);
gcMARK(ld->symtab);
gcMARK(ld->shared_offsets);
gcMARK(ld->insp);
gcMARK(ld->rn_memory);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Load_Delay));
}
mark_unmarshal_tables {
mark:
Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p;
gcMARK(ut->rns);
gcMARK(ut->rp);
gcMARK(ut->decoded);
size:
gcBYTES_TO_WORDS(sizeof(Scheme_Unmarshal_Tables));
}
END read;
/**********************************************************************/

47
src/mzscheme/src/portfun.c
View File

@ -100,6 +100,9 @@ static Scheme_Object *load (int, Scheme_Object *[]);
static Scheme_Object *current_load (int, Scheme_Object *[]);
static Scheme_Object *current_load_directory(int argc, Scheme_Object *argv[]);
static Scheme_Object *current_write_directory(int argc, Scheme_Object *argv[]);
#ifdef LOAD_ON_DEMAND
static Scheme_Object *load_on_demand_enabled(int argc, Scheme_Object *argv[]);
#endif
static Scheme_Object *default_load (int, Scheme_Object *[]);
static Scheme_Object *transcript_on(int, Scheme_Object *[]);
static Scheme_Object *transcript_off(int, Scheme_Object *[]);
@ -660,6 +663,13 @@ scheme_init_port_fun(Scheme_Env *env)
"current-write-relative-directory",
MZCONFIG_WRITE_DIRECTORY),
env);
#ifdef LOAD_ON_DEMAND
scheme_add_global_constant("load-on-demand-enabled",
scheme_register_parameter(load_on_demand_enabled,
"load-on-demand-enabled",
MZCONFIG_LOAD_DELAY_ENABLED),
env);
#endif
scheme_add_global_constant ("transcript-on",
scheme_make_prim_w_arity(transcript_on,
@ -2912,7 +2922,7 @@ static Scheme_Object *sch_default_read_handler(void *ignore, int argc, Scheme_Ob
else
src = NULL;
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL);
return scheme_internal_read(argv[0], src, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
static int extract_recur_args(const char *who, int argc, Scheme_Object **argv, int delta, Scheme_Object **_readtable)
@ -2966,7 +2976,8 @@ static Scheme_Object *do_read_f(const char *who, int argc, Scheme_Object *argv[]
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, NULL, -1, 0, honu_mode, recur, pre_char, readtable, NULL, NULL);
return scheme_internal_read(port, NULL, -1, 0, honu_mode, recur, pre_char, readtable,
NULL, NULL, NULL);
}
}
@ -3032,7 +3043,8 @@ static Scheme_Object *do_read_syntax_f(const char *who, int argc, Scheme_Object
if (port == scheme_orig_stdin_port)
scheme_flush_orig_outputs();
return scheme_internal_read(port, src, -1, 0, honu_mode, recur, pre_char, readtable, NULL, NULL);
return scheme_internal_read(port, src, -1, 0, honu_mode, recur, pre_char, readtable,
NULL, NULL, NULL);
}
}
@ -4201,6 +4213,7 @@ typedef struct {
Scheme_Thread *p;
Scheme_Object *stxsrc;
Scheme_Object *expected_module;
Scheme_Object *delay_load_info;
} LoadHandlerData;
static void post_load_handler(void *data)
@ -4220,7 +4233,8 @@ static Scheme_Object *do_load_handler(void *data)
Scheme_Env *genv;
int save_count = 0, got_one = 0;
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL))
while ((obj = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL,
NULL, NULL, lhd->delay_load_info))
&& !SCHEME_EOFP(obj)) {
save_array = NULL;
got_one = 1;
@ -4297,7 +4311,7 @@ static Scheme_Object *do_load_handler(void *data)
}
/* Check no more expressions: */
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL);
d = scheme_internal_read(port, lhd->stxsrc, 1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
if (!SCHEME_EOFP(d)) {
Scheme_Input_Port *ip;
ip = scheme_input_port_record(port);
@ -4373,7 +4387,7 @@ static Scheme_Object *do_load_handler(void *data)
static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
{
Scheme_Object *port, *name, *expected_module, *v;
int ch;
int ch, use_delay_load;
Scheme_Thread *p = scheme_current_thread;
Scheme_Config *config;
LoadHandlerData *lhd;
@ -4428,8 +4442,13 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
}
config = scheme_current_config();
v = scheme_get_param(config, MZCONFIG_LOAD_DELAY_ENABLED);
use_delay_load = SCHEME_TRUEP(v);
if (SCHEME_TRUEP(expected_module)) {
config = scheme_extend_config(config, MZCONFIG_CASE_SENS, (scheme_case_sensitive ? scheme_true : scheme_false)); /* for legacy code */
config = scheme_extend_config(config, MZCONFIG_CASE_SENS,
(scheme_case_sensitive ? scheme_true : scheme_false)); /* for legacy code */
config = scheme_extend_config(config, MZCONFIG_SQUARE_BRACKETS_ARE_PARENS, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CURLY_BRACES_ARE_PARENS, scheme_true);
config = scheme_extend_config(config, MZCONFIG_CAN_READ_GRAPH, scheme_true);
@ -4452,6 +4471,10 @@ static Scheme_Object *default_load(int argc, Scheme_Object *argv[])
name = scheme_input_port_record(port)->name;
lhd->stxsrc = name;
lhd->expected_module = expected_module;
if (use_delay_load) {
v = scheme_path_to_complete_path(argv[0], NULL);
lhd->delay_load_info = v;
}
if (SCHEME_TRUEP(expected_module)) {
scheme_push_continuation_frame(&cframe);
@ -4580,6 +4603,16 @@ current_write_directory(int argc, Scheme_Object *argv[])
-1, wr_abs_directory_p, "path, string, or #f", 1);
}
#ifdef LOAD_ON_DEMAND
static Scheme_Object *
load_on_demand_enabled(int argc, Scheme_Object *argv[])
{
return scheme_param_config("load-on-demand-enabled",
scheme_make_integer(MZCONFIG_LOAD_DELAY_ENABLED),
argc, argv, -1, NULL, NULL, 1);
}
#endif
Scheme_Object *scheme_load(const char *file)
{
Scheme_Object *p[1];

736
src/mzscheme/src/print.c
View File

File diff suppressed because it is too large Load Diff

438
src/mzscheme/src/read.c
View File

@ -66,6 +66,9 @@ static Scheme_Object *read_decimal_as_inexact(int, Scheme_Object *[]);
static Scheme_Object *read_accept_dot(int, Scheme_Object *[]);
static Scheme_Object *read_accept_quasi(int, Scheme_Object *[]);
static Scheme_Object *read_accept_reader(int, Scheme_Object *[]);
#ifdef LOAD_ON_DEMAND
static Scheme_Object *read_delay_load(int, Scheme_Object *[]);
#endif
static Scheme_Object *print_graph(int, Scheme_Object *[]);
static Scheme_Object *print_struct(int, Scheme_Object *[]);
static Scheme_Object *print_box(int, Scheme_Object *[]);
@ -124,6 +127,7 @@ typedef struct ReadParams {
int honu_mode;
Readtable *table;
Scheme_Object *magic_sym, *magic_val;
Scheme_Object *delay_load_info;
} ReadParams;
#define THREAD_FOR_LOCALS scheme_current_thread
@ -475,6 +479,13 @@ void scheme_init_read(Scheme_Env *env)
"read-accept-reader",
MZCONFIG_CAN_READ_READER),
env);
#ifdef LOAD_ON_DEMAND
scheme_add_global_constant("read-on-demand-source",
scheme_register_parameter(read_delay_load,
"read-on-demand-source",
MZCONFIG_DELAY_LOAD_INFO),
env);
#endif
scheme_add_global_constant("print-graph",
scheme_register_parameter(print_graph,
"print-graph",
@ -712,6 +723,24 @@ print_honu(int argc, Scheme_Object *argv[])
DO_CHAR_PARAM("print-honu", MZCONFIG_HONU_MODE);
}
#ifdef LOAD_ON_DEMAND
static Scheme_Object *rdl_check(int argc, Scheme_Object **argv)
{
return argv[0];
}
static Scheme_Object *
read_delay_load(int argc, Scheme_Object *argv[])
{
return scheme_param_config("read-on-demand-source",
scheme_make_integer(MZCONFIG_DELAY_LOAD_INFO),
argc, argv,
-1, rdl_check,
"complete path or string, optionally paired with an exact integer", 1);
}
#endif
/*========================================================================*/
/* main read loop */
/*========================================================================*/
@ -1840,7 +1869,8 @@ static Scheme_Object *resolve_references(Scheme_Object *obj,
Scheme_Object *
_scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int honu_mode,
int recur, int extra_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val)
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info)
{
Scheme_Object *v, *v2;
Scheme_Config *config;
@ -1875,6 +1905,12 @@ _scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int h
params.can_read_quasi = SCHEME_TRUEP(v);
v = scheme_get_param(config, MZCONFIG_CAN_READ_DOT);
params.can_read_dot = SCHEME_TRUEP(v);
if (!delay_load_info)
delay_load_info = scheme_get_param(config, MZCONFIG_DELAY_LOAD_INFO);
if (SCHEME_TRUEP(delay_load_info))
params.delay_load_info = delay_load_info;
else
params.delay_load_info = NULL;
params.honu_mode = honu_mode;
if (honu_mode)
params.table = NULL;
@ -1966,7 +2002,8 @@ static void *scheme_internal_read_k(void)
Scheme_Object *stxsrc = (Scheme_Object *)p->ku.k.p2;
Scheme_Object *init_readtable = (Scheme_Object *)p->ku.k.p3;
Scheme_Object *magic_sym = (Scheme_Object *)p->ku.k.p4;
Scheme_Object *magic_val = (Scheme_Object *)p->ku.k.p5;
Scheme_Object *magic_val = NULL;
Scheme_Object *delay_load_info = (Scheme_Object *)p->ku.k.p5;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
@ -1974,15 +2011,21 @@ static void *scheme_internal_read_k(void)
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
if (magic_sym) {
magic_val = SCHEME_CDR(magic_sym);
magic_sym = SCHEME_CAR(magic_sym);
}
return (void *)_scheme_internal_read(port, stxsrc, p->ku.k.i1, p->ku.k.i2,
p->ku.k.i3, p->ku.k.i4, init_readtable,
magic_sym, magic_val);
magic_sym, magic_val, delay_load_info);
}
Scheme_Object *
scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail, int honu_mode,
int recur, int pre_char, Scheme_Object *init_readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val)
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info)
{
Scheme_Thread *p = scheme_current_thread;
@ -1994,8 +2037,12 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
scheme_alloc_list_stack(p);
if (cantfail) {
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, -1, NULL, magic_sym, magic_val);
return _scheme_internal_read(port, stxsrc, crc, honu_mode, recur, -1, NULL,
magic_sym, magic_val, delay_load_info);
} else {
if (magic_sym)
magic_sym = scheme_make_pair(magic_sym, magic_val);
p->ku.k.p1 = (void *)port;
p->ku.k.p2 = (void *)stxsrc;
p->ku.k.i1 = crc;
@ -2004,7 +2051,7 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
p->ku.k.i4 = pre_char;
p->ku.k.p3 = (void *)init_readtable;
p->ku.k.p4 = (void *)magic_sym;
p->ku.k.p5 = (void *)magic_val;
p->ku.k.p5 = (void *)delay_load_info;
return (Scheme_Object *)scheme_top_level_do(scheme_internal_read_k, 0);
}
@ -2012,12 +2059,12 @@ scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int ca
Scheme_Object *scheme_read(Scheme_Object *port)
{
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL);
return scheme_internal_read(port, NULL, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_read_syntax(Scheme_Object *port, Scheme_Object *stxsrc)
{
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL);
return scheme_internal_read(port, stxsrc, -1, 0, 0, 0, -1, NULL, NULL, NULL, NULL);
}
Scheme_Object *scheme_resolve_placeholders(Scheme_Object *obj, int mkstx)
@ -3832,6 +3879,17 @@ static void pop_indentation(Scheme_Object *indentation)
/* .zo reader */
/*========================================================================*/
typedef struct Scheme_Load_Delay {
MZTAG_IF_REQUIRED
Scheme_Object *path;
long file_offset, size;
unsigned long symtab_size;
Scheme_Object **symtab;
long *shared_offsets;
Scheme_Object *insp;
Scheme_Hash_Table *rn_memory;
} Scheme_Load_Delay;
#define ZO_CHECK(x) if (!(x)) scheme_ill_formed_code(port);
#define RANGE_CHECK(x, y) ZO_CHECK (x y)
#define RANGE_CHECK_GETS(x) RANGE_CHECK(x, <= port->size - port->pos)
@ -3842,12 +3900,14 @@ typedef struct CPort {
unsigned char *start;
unsigned long symtab_size;
long base;
int flags;
Scheme_Object *orig_port;
Scheme_Hash_Table **ht;
Scheme_Unmarshal_Tables *ut;
Scheme_Object **symtab;
Scheme_Object *insp; /* inspector for module-variable access */
Scheme_Object *magic_sym, *magic_val;
long *shared_offsets;
Scheme_Load_Delay *delay_info;
} CPort;
#define CP_GETC(cp) ((int)(cp->start[cp->pos++]))
#define CP_TELL(port) (port->pos + port->base)
@ -3877,29 +3937,24 @@ void scheme_ill_formed(struct CPort *port
XFORM_NONGCING static long read_compact_number(CPort *port)
{
/* >>> See also read_compact_number_from_port(), below. <<< */
long flag, v, a, b, c, d;
NUM_ZO_CHECK(port->pos < port->size);
flag = CP_GETC(port);
if (flag < 252)
if (flag < 128)
return flag;
else if (flag == 252) {
NUM_ZO_CHECK(port->pos + 1 < port->size);
a = CP_GETC(port);
b = CP_GETC(port);
v = a
+ (b << 8);
return v;
} else if (flag == 254) {
else if (!(flag & 0x40)) {
NUM_ZO_CHECK(port->pos < port->size);
return -CP_GETC(port);
a = CP_GETC(port);
v = (flag & 0x3F)
+ (a << 6);
return v;
} else if (!(flag & 0x20)) {
return -(flag & 0x1F);
}
NUM_ZO_CHECK(port->pos + 3 < port->size);
@ -3914,7 +3969,7 @@ XFORM_NONGCING static long read_compact_number(CPort *port)
+ (c << 16)
+ (d << 24);
if (flag == 253)
if (flag & 0x10)
return v;
else
return -v;
@ -4005,7 +4060,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
switch(cpt_branch[ch]) {
case CPT_ESCAPE:
case CPT_HASHED_ESCAPE:
{
int len;
Scheme_Object *ep;
@ -4043,12 +4097,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
params.table = NULL;
v = read_inner(ep, NULL, port->ht, scheme_null, &params, 0);
if (ch == CPT_HASHED_ESCAPE) {
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
}
}
break;
case CPT_SYMBOL:
@ -4059,15 +4107,18 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
if (SAME_OBJ(v, port->magic_sym))
v = port->magic_val;
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
break;
case CPT_SYMREF:
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
v = port->symtab[l];
if (!v) {
long save_pos = port->pos;
port->pos = port->shared_offsets[l - 1];
v = read_compact(port, 0);
port->pos = save_pos;
port->symtab[l] = v;
}
break;
case CPT_WEIRD_SYMBOL:
{
@ -4083,11 +4134,8 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = scheme_make_exact_symbol(s, l);
else
v = scheme_intern_exact_parallel_symbol(s, l);
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
/* The fact that other uses of the symbol go through the table
/* The fact that all uses of the symbol go through the table
means that uninterned symbols are consistently re-created for
a particular compiled expression. */
}
@ -4097,20 +4145,12 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
RANGE_CHECK_GETS(l);
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_intern_exact_keyword(s, l);
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
break;
case CPT_BYTE_STRING:
l = read_compact_number(port);
RANGE_CHECK_GETS(l);
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_make_immutable_sized_byte_string(s, l, l < BLK_BUF_SIZE);
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
break;
case CPT_CHAR_STRING:
{
@ -4124,10 +4164,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
scheme_utf8_decode_all((const unsigned char *)s, el, us, 0);
us[l] = 0;
v = scheme_make_immutable_sized_char_string(us, l, 0);
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
}
break;
case CPT_CHAR:
@ -4218,7 +4254,7 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
l = scheme_make_pair(scheme_make_pair(k, v), l);
}
/* Map an unintenred sym to l so that resolve_references
/* Map an uninterned sym to l so that resolve_references
completes the table construction. */
scheme_hash_set(t, an_uninterned_symbol, l);
if (!(*port->ht)) {
@ -4234,15 +4270,26 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
case CPT_STX:
case CPT_GSTX:
{
if (!local_rename_memory) {
if (!port->ut) {
Scheme_Unmarshal_Tables *ut;
Scheme_Hash_Table *rht;
char *decoded;
ut = MALLOC_ONE_RT(Scheme_Unmarshal_Tables);
SET_REQUIRED_TAG(ut->type = scheme_rt_unmarshal_info);
port->ut = ut;
ut->rp = port;
decoded = (char *)scheme_malloc_atomic(port->symtab_size);
memset(decoded, 0, port->symtab_size);
ut->decoded = decoded;
rht = scheme_make_hash_table(SCHEME_hash_ptr);
local_rename_memory = rht;
port->ut->rns = rht;
}
v = read_compact(port, 1);
v = scheme_datum_to_syntax(v, scheme_false, (Scheme_Object *)local_rename_memory,
ch == CPT_GSTX, 0);
v = scheme_unmarshal_datum_to_syntax(v, port->ut, ch == CPT_GSTX);
scheme_num_read_syntax_objects++;
if (!v)
scheme_ill_formed_code(port);
@ -4332,14 +4379,10 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
{
Scheme_Object *path, *base;
l = read_compact_number(port); /* symtab index */
path = read_compact(port, 0);
base = read_compact(port, 0);
v = scheme_make_modidx(path, base, scheme_false);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
}
break;
case CPT_MODULE_VAR:
@ -4348,7 +4391,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
Scheme_Object *mod, *var;
int pos;
l = read_compact_number(port); /* symtab index */
mod = read_compact(port, 0);
var = read_compact(port, 0);
pos = read_compact_number(port);
@ -4361,9 +4403,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
mv->pos = pos;
v = (Scheme_Object *)mv;
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
}
break;
case CPT_PATH:
@ -4372,7 +4411,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
RANGE_CHECK_GETS(l);
s = read_compact_chars(port, buffer, BLK_BUF_SIZE, l);
v = scheme_make_sized_path(s, l, l < BLK_BUF_SIZE);
l = read_compact_number(port); /* symtab index */
if (scheme_is_relative_path(SCHEME_PATH_VAL(v), SCHEME_PATH_LEN(v), SCHEME_PLATFORM_PATH_KIND)) {
/* Resolve relative path using the current load-relative directory: */
@ -4385,14 +4423,13 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = scheme_build_path(2, a);
}
}
port->symtab[l] = v;
}
break;
case CPT_CLOSURE:
{
Scheme_Closure *cl;
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
cl = scheme_malloc_empty_closure();
port->symtab[l] = (Scheme_Object *)cl;
v = read_compact(port, 0);
@ -4405,6 +4442,27 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
v = (Scheme_Object *)cl;
break;
}
case CPT_DELAY_REF:
{
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
v = port->symtab[l];
if (!v) {
if (port->delay_info) {
/* This is where we construct information for
loading the syntax object on demand. */
v = scheme_make_raw_pair(scheme_make_integer(l),
(Scheme_Object *)port->delay_info);
} else {
long save_pos = port->pos;
port->pos = port->shared_offsets[l - 1];
v = read_compact(port, 0);
port->pos = save_pos;
port->symtab[l] = v;
}
}
break;
}
case CPT_SMALL_LOCAL_START:
case CPT_SMALL_LOCAL_UNBOX_START:
{
@ -4441,10 +4499,6 @@ static Scheme_Object *read_compact(CPort *port, int use_stack)
if (SAME_OBJ(v, port->magic_sym))
v = port->magic_val;
l = read_compact_number(port);
RANGE_CHECK(l, < port->symtab_size);
port->symtab[l] = v;
}
break;
case CPT_SMALL_NUMBER_START:
@ -4698,40 +4752,19 @@ static Scheme_Object *read_marshalled(int type, CPort *port)
return l;
}
static long read_compact_number_from_port(Scheme_Object *port)
static long read_simple_number_from_port(Scheme_Object *port)
{
/* >>> See also read_compact_number(), above. <<< */
long a, b, c, d;
long flag, v, a, b, c, d;
a = (unsigned char)scheme_get_byte(port);
b = (unsigned char)scheme_get_byte(port);
c = (unsigned char)scheme_get_byte(port);
d = (unsigned char)scheme_get_byte(port);
flag = scheme_get_byte(port);
if (flag < 252)
return flag;
if (flag == 254)
return -scheme_get_byte(port);
a = scheme_get_byte(port);
b = scheme_get_byte(port);
if (flag == 252) {
v = a
+ (b << 8);
return v;
}
c = scheme_get_byte(port);
d = scheme_get_byte(port);
v = a
+ (b << 8)
+ (c << 16)
+ (d << 24);
if (flag == 253)
return v;
else
return -v;
return (a
+ (b << 8)
+ (c << 16)
+ (d << 24));
}
/* "#~" has been read */
@ -4743,10 +4776,13 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *result, *insp;
long size, got;
long size, shared_size, got, offset = 0;
CPort *rp;
long symtabsize;
Scheme_Object **symtab;
long *so;
Scheme_Load_Delay *delay_info;
int all_short;
if (USE_LISTSTACK(!p->list_stack))
scheme_alloc_list_stack(p);
@ -4780,8 +4816,16 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
if (!variable_references)
variable_references = scheme_make_builtin_references_table();
/* Allow delays? */
if (params->delay_load_info) {
delay_info = MALLOC_ONE_RT(Scheme_Load_Delay);
SET_REQUIRED_TAG(delay_info->type = scheme_rt_delay_load_info);
delay_info->path = params->delay_load_info;
} else
delay_info = NULL;
/* Check version: */
size = read_compact_number_from_port(port);
size = scheme_get_byte(port);
{
char buf[64];
@ -4796,17 +4840,59 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
"read (compiled): code compiled for version %s, not %s",
(buf[0] ? buf : "???"), MZSCHEME_VERSION);
}
offset += size + 1;
symtabsize = read_compact_number_from_port(port);
symtabsize = read_simple_number_from_port(port);
offset += 4;
/* Load table mapping symtab indices to stream positions: */
all_short = scheme_get_byte(port);
so = (long *)scheme_malloc_atomic(sizeof(long) * symtabsize);
if ((got = scheme_get_bytes(port, (all_short ? 2 : 4) * (symtabsize - 1), (char *)so, 0))
!= ((all_short ? 2 : 4) * (symtabsize - 1)))
scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
"read (compiled): ill-formed code (bad table count: %ld != %ld)",
got, (all_short ? 2 : 4) * (symtabsize - 1));
offset += got;
{
/* This loop runs top to bottom, since sizeof(long) may be larger
than the decoded integers (but it's never shorter) */
long j, v;
unsigned char *so_c = (unsigned char *)so;
for (j = symtabsize - 1; j--; ) {
if (all_short) {
v = so_c[j * 2]
+ (so_c[j * 2 + 1] << 8);
} else {
v = so_c[j * 4]
+ (so_c[j * 4 + 1] << 8)
+ (so_c[j * 4 + 2] << 16)
+ (so_c[j * 4 + 3] << 24);
}
so[j] = v;
}
}
/* Continue reading content */
shared_size = read_simple_number_from_port(port);
size = read_simple_number_from_port(port);
if (shared_size >= size) {
scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
"read (compiled): ill-formed code (shared size %ld >= total size %ld)",
shared_size, size);
}
offset += 8;
size = read_compact_number_from_port(port);
rp = MALLOC_ONE_RT(CPort);
#ifdef MZ_PRECISE_GC
rp->type = scheme_rt_compact_port;
#endif
SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
{
unsigned char *st;
st = (unsigned char *)scheme_malloc_atomic(size);
st = (unsigned char *)scheme_malloc_atomic(size + 1);
rp->start = st;
}
rp->pos = 0;
@ -4822,8 +4908,6 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
"read (compiled): ill-formed code (bad count: %ld != %ld, started at %ld)",
got, size, rp->base);
local_rename_memory = NULL;
symtab = MALLOC_N(Scheme_Object *, symtabsize);
rp->symtab_size = symtabsize;
rp->ht = ht;
@ -4835,9 +4919,37 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
rp->magic_sym = params->magic_sym;
rp->magic_val = params->magic_val;
result = read_marshalled(scheme_compilation_top_type, rp);
rp->shared_offsets = so;
rp->delay_info = delay_info;
local_rename_memory = NULL;
if (!delay_info) {
/* Read shared parts: */
long j, len;
Scheme_Object *v;
len = symtabsize;
for (j = 1; j < len; j++) {
if (!symtab[j]) {
v = read_compact(rp, 0);
symtab[j] = v;
} else {
if (j+1 < len)
rp->pos = so[j];
else
rp->pos = shared_size;
}
}
} else {
rp->pos = shared_size; /* skip shared part */
delay_info->file_offset = offset + 2; /* +2 is for #~ */
delay_info->size = shared_size;
delay_info->symtab_size = rp->symtab_size;
delay_info->symtab = rp->symtab;
delay_info->shared_offsets = rp->shared_offsets;
delay_info->insp = rp->insp;
}
/* Read main body: */
result = read_marshalled(scheme_compilation_top_type, rp);
if (SAME_TYPE(SCHEME_TYPE(result), scheme_compilation_top_type)) {
Scheme_Compilation_Top *top = (Scheme_Compilation_Top *)result;
@ -4855,6 +4967,100 @@ static Scheme_Object *read_compiled(Scheme_Object *port,
return result;
}
Scheme_Object *scheme_load_delayed_code(int which, Scheme_Load_Delay *delay_info)
{
CPort *rp;
char *filename;
long size, got;
unsigned char *st;
Scheme_Object *port, *v;
Scheme_Hash_Table **ht;
filename = scheme_expand_filename(SCHEME_PATH_VAL(delay_info->path),
SCHEME_PATH_LEN(delay_info->path),
NULL, NULL, 0);
port = scheme_open_input_file(filename, "on-demand-loader");
size = delay_info->size;
rp = MALLOC_ONE_RT(CPort);
SET_REQUIRED_TAG(rp->type = scheme_rt_compact_port);
st = (unsigned char *)scheme_malloc_atomic(size + 1);
rp->start = st;
rp->pos = 0;
rp->base = 0;
rp->orig_port = port;
rp->size = size;
ht = MALLOC_N(Scheme_Hash_Table *, 1);
scheme_set_file_position(port, delay_info->file_offset);
if ((got = scheme_get_bytes(port, size, (char *)rp->start, 0)) != size)
scheme_read_err(port, NULL, -1, -1, -1, -1, 0, NULL,
"on-demand load: ill-formed code (bad count: %ld != %ld, started at %ld)",
got, size, rp->base);
scheme_close_input_port(port);
rp->symtab_size = delay_info->symtab_size;
rp->ht = ht;
rp->symtab = delay_info->symtab;
rp->insp = delay_info->insp;
rp->shared_offsets = delay_info->shared_offsets;
rp->delay_info = delay_info;
rp->pos = delay_info->shared_offsets[which - 1];
v = read_compact(rp, 0);
delay_info->symtab[which] = v;
if (*ht) {
resolve_references(v, NULL, 0);
}
return v;
}
Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut,
Scheme_Object *wraps_key,
int *_decoded)
{
long l;
l = SCHEME_INT_VAL(wraps_key);
if ((l < 0) || (l >= ut->rp->symtab_size))
scheme_ill_formed_code(ut->rp);
if (!ut->rp->symtab[l]) {
Scheme_Object *v;
long save_pos;
if (!ut->rp->delay_info)
scheme_ill_formed_code(ut->rp);
save_pos = ut->rp->pos;
ut->rp->pos = ut->rp->shared_offsets[l - 1];
v = read_compact(ut->rp, 0);
ut->rp->pos = save_pos;
ut->rp->symtab[l] = v;
}
*_decoded = ut->decoded[l];
return ut->rp->symtab[l];
}
void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut,
Scheme_Object *wraps_key,
Scheme_Object *v)
{
long l;
l = SCHEME_INT_VAL(wraps_key);
ut->rp->symtab[l] = v;
ut->decoded[l] = 1;
}
/*========================================================================*/
/* readtable support */
/*========================================================================*/
@ -5499,6 +5705,8 @@ static void register_traversers(void)
GC_REG_TRAV(scheme_rt_compact_port, mark_cport);
GC_REG_TRAV(scheme_readtable_type, mark_readtable);
GC_REG_TRAV(scheme_rt_read_params, mark_read_params);
GC_REG_TRAV(scheme_rt_delay_load_info, mark_delay_load);
GC_REG_TRAV(scheme_rt_unmarshal_info, mark_unmarshal_tables);
}
END_XFORM_SKIP;

1
src/mzscheme/src/regexp.c
View File

@ -3891,7 +3891,6 @@ char *regsub(regexp *prog, char *src, int sourcelen, long *lenout, char *insrc,
/* code points. */
/************************************************************/
/* To avoid the broken qsort in Solaris: */
#ifdef MZ_XFORM
START_XFORM_SKIP;
#endif

2
src/mzscheme/src/schcpt.h
View File

@ -33,7 +33,7 @@ enum {
CPT_MODULE_VAR, /* 30 */
CPT_PATH,
CPT_CLOSURE,
CPT_HASHED_ESCAPE,
CPT_DELAY_REF,
_CPT_COUNT_
};

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

@ -798,6 +798,7 @@ MZ_EXTERN char *scheme_getdrive(void);
MZ_EXTERN Scheme_Object *scheme_split_path(const char *path, int len, Scheme_Object **base, int *isdir, int kind);
MZ_EXTERN Scheme_Object *scheme_build_path(int argc, Scheme_Object **argv);
MZ_EXTERN Scheme_Object *scheme_path_to_directory_path(Scheme_Object *p);
MZ_EXTERN Scheme_Object *scheme_path_to_complete_path(Scheme_Object *path, Scheme_Object *relto_path);
MZ_EXTERN Scheme_Object *scheme_make_path(const char *chars);
MZ_EXTERN Scheme_Object *scheme_make_sized_path(char *chars, long len, int copy);

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

@ -668,6 +668,7 @@ char *(*scheme_getdrive)(void);
Scheme_Object *(*scheme_split_path)(const char *path, int len, Scheme_Object **base, int *isdir, int kind);
Scheme_Object *(*scheme_build_path)(int argc, Scheme_Object **argv);
Scheme_Object *(*scheme_path_to_directory_path)(Scheme_Object *p);
Scheme_Object *(*scheme_path_to_complete_path)(Scheme_Object *path, Scheme_Object *relto_path);
Scheme_Object *(*scheme_make_path)(const char *chars);
Scheme_Object *(*scheme_make_sized_path)(char *chars, long len, int copy);
Scheme_Object *(*scheme_make_sized_offset_path)(char *chars, long d, long len, int copy);

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

@ -448,6 +448,7 @@
scheme_extension_table->scheme_split_path = scheme_split_path;
scheme_extension_table->scheme_build_path = scheme_build_path;
scheme_extension_table->scheme_path_to_directory_path = scheme_path_to_directory_path;
scheme_extension_table->scheme_path_to_complete_path = scheme_path_to_complete_path;
scheme_extension_table->scheme_make_path = scheme_make_path;
scheme_extension_table->scheme_make_sized_path = scheme_make_sized_path;
scheme_extension_table->scheme_make_sized_offset_path = scheme_make_sized_offset_path;

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

@ -448,6 +448,7 @@
#define scheme_split_path (scheme_extension_table->scheme_split_path)
#define scheme_build_path (scheme_extension_table->scheme_build_path)
#define scheme_path_to_directory_path (scheme_extension_table->scheme_path_to_directory_path)
#define scheme_path_to_complete_path (scheme_extension_table->scheme_path_to_complete_path)
#define scheme_make_path (scheme_extension_table->scheme_make_path)
#define scheme_make_sized_path (scheme_extension_table->scheme_make_sized_path)
#define scheme_make_sized_offset_path (scheme_extension_table->scheme_make_sized_offset_path)

78
src/mzscheme/src/schpriv.h
View File

@ -98,8 +98,10 @@ int scheme_num_types(void);
#ifdef MZTAG_REQUIRED
# define MZTAG_IF_REQUIRED Scheme_Type type;
# define SET_REQUIRED_TAG(e) e
#else
# define MZTAG_IF_REQUIRED /* empty */
# define SET_REQUIRED_TAG(e) /* empty */
#endif
void scheme_reset_finalizations(void);
@ -559,6 +561,9 @@ typedef struct Scheme_Stx_Offset {
Scheme_Object *src;
} Scheme_Stx_Offset;
struct Scheme_Marshal_Tables;
struct Scheme_Unmarshal_Tables;
Scheme_Object *scheme_make_stx(Scheme_Object *val,
Scheme_Stx_Srcloc *srcloc,
Scheme_Object *props);
@ -578,7 +583,10 @@ Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o, Scheme_Object *stx_src,
Scheme_Object *stx_wraps,
int cangraph, int copyprops);
Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks,
Scheme_Hash_Table *renames);
struct Scheme_Marshal_Tables *mt);
Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o,
struct Scheme_Unmarshal_Tables *ut,
int can_graph);
int scheme_syntax_is_graph(Scheme_Object *stx);
@ -691,6 +699,8 @@ Scheme_Object *scheme_stx_add_inactive_certs(Scheme_Object *o, Scheme_Object *ce
int scheme_stx_has_more_certs(Scheme_Object *id, Scheme_Object *certs,
Scheme_Object *than_id, Scheme_Object *than_certs);
Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i);
/*========================================================================*/
/* syntax run-time structures */
/*========================================================================*/
@ -747,7 +757,9 @@ typedef struct Scheme_Let_Header {
Scheme_Object *body;
} Scheme_Let_Header;
#define SCHEME_LET_RECURSIVE(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define SCHEME_LET_FLAGS(lh) MZ_OPT_HASH_KEY(&lh->iso)
#define SCHEME_LET_RECURSIVE 0x1
#define SCHEME_LET_STAR 0x2
typedef struct {
Scheme_Object so;
@ -1521,7 +1533,8 @@ Scheme_Object *_scheme_tail_apply_to_list (Scheme_Object *rator, Scheme_Object *
Scheme_Object *scheme_internal_read(Scheme_Object *port, Scheme_Object *stxsrc, int crc, int cantfail,
int honu_mode, int recur, int pre_char, Scheme_Object *readtable,
Scheme_Object *magic_sym, Scheme_Object *magic_val);
Scheme_Object *magic_sym, Scheme_Object *magic_val,
Scheme_Object *delay_load_info);
void scheme_internal_display(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_write(Scheme_Object *obj, Scheme_Object *port);
void scheme_internal_print(Scheme_Object *obj, Scheme_Object *port);
@ -1567,6 +1580,9 @@ Scheme_Object *scheme_force_one_value_same_mark(Scheme_Object *);
void scheme_flush_stack_cache(void);
struct Scheme_Load_Delay;
Scheme_Object *scheme_load_delayed_code(int pos, struct Scheme_Load_Delay *ld);
/*========================================================================*/
/* compile and link */
/*========================================================================*/
@ -1639,6 +1655,8 @@ typedef struct Resolve_Prefix
int num_toplevels, num_stxes, num_lifts;
Scheme_Object **toplevels;
Scheme_Object **stxes; /* simplified */
int delay_refcount;
struct Scheme_Load_Delay *delay_info;
} Resolve_Prefix;
typedef struct Resolve_Info
@ -1865,14 +1883,13 @@ int scheme_is_sub_env(Scheme_Comp_Env *stx_env, Scheme_Comp_Env *env);
#define CASE_LAMBDA_EXPD 3
#define BEGIN0_EXPD 4
#define BOXENV_EXPD 5
#define BOXVAL_EXPD 6
#define MODULE_EXPD 7
#define REQUIRE_EXPD 8
#define DEFINE_FOR_SYNTAX_EXPD 9
#define REF_EXPD 10
#define APPVALS_EXPD 11
#define SPLICE_EXPD 12
#define _COUNT_EXPD_ 13
#define MODULE_EXPD 6
#define REQUIRE_EXPD 7
#define DEFINE_FOR_SYNTAX_EXPD 8
#define REF_EXPD 9
#define APPVALS_EXPD 10
#define SPLICE_EXPD 11
#define _COUNT_EXPD_ 12
#define scheme_register_syntax(i, fo, fr, fv, fe, fj, cl, sh, pa) \
(scheme_syntax_optimizers[i] = fo, \
@ -2161,6 +2178,45 @@ Scheme_Object *scheme_check_name_property(Scheme_Object *stx, Scheme_Object *cur
Scheme_Object *scheme_make_lifted_defn(Scheme_Object *sys_wraps, Scheme_Object **_id, Scheme_Object *expr, Scheme_Comp_Env *env);
typedef struct Scheme_Marshal_Tables {
MZTAG_IF_REQUIRED
int pass, print_now;
Scheme_Hash_Table *symtab;
Scheme_Hash_Table *rns;
Scheme_Hash_Table *rn_refs;
Scheme_Hash_Table *st_refs;
Scheme_Object *st_ref_stack;
Scheme_Hash_Table *reverse_map; /* used on first pass */
Scheme_Hash_Table *same_map; /* set on first pass, used on later passes */
Scheme_Hash_Table *top_map; /* used on every pass */
Scheme_Hash_Table *key_map; /* set after first pass, used on later passes */
Scheme_Hash_Table *delay_map; /* set during first pass, used on later passes */
Scheme_Hash_Table *rn_saved; /* maps each original object to generated marshaling */
long *shared_offsets; /* set in second pass */
long sorted_keys_count;
Scheme_Object **sorted_keys;
} Scheme_Marshal_Tables;
void scheme_marshal_using_key(Scheme_Marshal_Tables *mt, Scheme_Object *key);
Scheme_Object *scheme_marshal_lookup(Scheme_Marshal_Tables *mt, Scheme_Object *a);
Scheme_Object *scheme_marshal_wrap_set(Scheme_Marshal_Tables *mt, Scheme_Object *a, Scheme_Object *v);
void scheme_marshal_push_refs(Scheme_Marshal_Tables *mt);
void scheme_marshal_pop_refs(Scheme_Marshal_Tables *mt, int keep);
typedef struct Scheme_Unmarshal_Tables {
MZTAG_IF_REQUIRED
Scheme_Hash_Table *rns;
struct CPort *rp;
char *decoded;
} Scheme_Unmarshal_Tables;
Scheme_Object *scheme_unmarshal_wrap_get(Scheme_Unmarshal_Tables *ut,
Scheme_Object *wraps_key,
int *_decoded);
void scheme_unmarshal_wrap_set(Scheme_Unmarshal_Tables *ut,
Scheme_Object *wraps_key,
Scheme_Object *v);
/*========================================================================*/
/* namespaces and modules */
/*========================================================================*/

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

@ -9,6 +9,6 @@
#define MZSCHEME_VERSION_MAJOR 369
#define MZSCHEME_VERSION_MINOR 2
#define MZSCHEME_VERSION_MINOR 3
#define MZSCHEME_VERSION "369.2" _MZ_SPECIAL_TAG
#define MZSCHEME_VERSION "369.3" _MZ_SPECIAL_TAG

3
src/mzscheme/src/startup.inc
View File

@ -2938,8 +2938,7 @@
"((current-eval)(if(syntax? v)"
"(namespace-syntax-introduce "
"(datum->syntax-object #f w v))"
" w))))"
"(default-continuation-prompt-tag)))"
" w))))))"
"(lambda results(for-each(current-print) results)))"
"(abort-current-continuation(default-continuation-prompt-tag)))))"
"(default-continuation-prompt-tag)"

3
src/mzscheme/src/startup.ss
View File

@ -3383,8 +3383,7 @@
((current-eval) (if (syntax? v)
(namespace-syntax-introduce
(datum->syntax-object #f w v))
w))))
(default-continuation-prompt-tag)))
w))))))
(lambda results (for-each (current-print) results)))
;; Abort to loop. (Calling `repl-loop' directory would not be a tail call.)
(abort-current-continuation (default-continuation-prompt-tag)))))

417
src/mzscheme/src/stxobj.c
View File

@ -1378,6 +1378,27 @@ Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename)
return (Scheme_Object *)stx;
}
Scheme_Object *scheme_delayed_rename(Scheme_Object **o, long i)
{
Scheme_Object *rename;
Resolve_Prefix *rp;
rename = o[0];
rp = (Resolve_Prefix *)o[1];
if (SCHEME_INTP(rp->stxes[i])) {
Scheme_Object *stx;
stx = scheme_load_delayed_code(SCHEME_INT_VAL(rp->stxes[i]),
rp->delay_info);
rp->stxes[i] = stx;
--rp->delay_refcount;
if (!rp->delay_refcount)
rp->delay_info = NULL;
}
return scheme_add_rename(rp->stxes[i], rename);
}
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib)
{
#if 0
@ -2451,13 +2472,12 @@ static Scheme_Object *lift_inactive_certs(Scheme_Object *o, int as_active)
Scheme_Hash_Table *ht = NULL;
o = stx_activate_certs(o, &certs, &ht);
if (!certs)
return o;
o = add_certs(o, certs, NULL, as_active);
if (certs)
o = add_certs(o, certs, NULL, as_active);
if (ht)
o = scheme_resolve_placeholders(o, 0);
o = scheme_resolve_placeholders(o, 1);
return o;
}
@ -3841,7 +3861,8 @@ static void simplify_lex_renames(Scheme_Object *wraps, Scheme_Hash_Table *lex_ca
}
static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
Scheme_Hash_Table *rns,
Scheme_Marshal_Tables *mt,
Scheme_Hash_Table *rns,
int just_simplify)
{
Scheme_Object *stack, *a, *old_key, *simplifies = scheme_null;
@ -3849,12 +3870,26 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
Scheme_Hash_Table *lex_cache, *reverse_map;
int stack_size = 0;
a = scheme_hash_get(rns, w_in);
if (!rns)
rns = mt->rns;
if (just_simplify) {
a = scheme_hash_get(rns, w_in);
} else {
if (mt->pass && mt->same_map) {
a = scheme_hash_get(mt->same_map, w_in);
if (a)
w_in = a;
}
a = scheme_marshal_lookup(mt, w_in);
}
if (a) {
if (just_simplify)
return SCHEME_CDR(a);
else
return SCHEME_CAR(a);
return a;
else {
scheme_marshal_using_key(mt, w_in);
return a;
}
}
WRAP_POS_INIT(w, w_in);
@ -3870,6 +3905,9 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
/* Ensures that all lexical tables in w have been simplified */
simplify_lex_renames(w_in, lex_cache);
if (mt)
scheme_marshal_push_refs(mt);
while (!WRAP_POS_END_P(w)) {
a = WRAP_POS_FIRST(w);
old_key = WRAP_POS_KEY(w);
@ -3909,20 +3947,14 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
} else {
Scheme_Object *local_key;
local_key = scheme_hash_get(rns, a);
local_key = scheme_marshal_lookup(mt, a);
if (local_key) {
stack = CONS(local_key, stack);
} else {
local_key = scheme_make_integer(rns->count);
scheme_hash_set(rns, a, local_key);
/* Since this is a simplified table, we can steal the first
slot for local_key: */
SCHEME_VEC_ELS(a)[0] = local_key;
stack = CONS(a, stack);
}
scheme_marshal_using_key(mt, a);
a = local_key;
} else {
a = scheme_marshal_wrap_set(mt, a, a);
}
stack = CONS(a, stack);
}
stack_size++;
}
@ -3986,10 +4018,8 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
} else {
Scheme_Object *local_key;
local_key = scheme_hash_get(rns, (Scheme_Object *)mrn);
if (local_key) {
stack = CONS(local_key, stack);
} else {
local_key = scheme_marshal_lookup(mt, (Scheme_Object *)mrn);
if (!local_key) {
/* Convert hash table to vector: */
int i, j, count = 0;
Scheme_Object *l, *idi;
@ -4019,9 +4049,6 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
}
}
local_key = scheme_make_integer(rns->count);
scheme_hash_set(rns, a, local_key);
if (mrn->marked_names && mrn->marked_names->count) {
Scheme_Object *d = scheme_null, *p;
@ -4046,10 +4073,17 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
l = CONS(scheme_true,l);
/* note: information on nominals intentially omitted */
}
l = CONS(local_key, l);
stack = CONS(l, stack);
}
local_key = scheme_marshal_lookup(mt, a);
if (local_key)
scheme_marshal_using_key(mt, a);
else {
local_key = scheme_marshal_wrap_set(mt, a, l);
}
} else {
scheme_marshal_using_key(mt, (Scheme_Object *)mrn);
}
stack = CONS(local_key, stack);
}
}
stack_size++;
@ -4106,30 +4140,57 @@ static Scheme_Object *wraps_to_datum(Scheme_Object *w_in,
stack= scheme_null;
}
/* Double-check for equivalent list in table (after simplificiation): */
reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined);
if (!reverse_map) {
reverse_map = scheme_make_hash_table_equal();
scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map);
}
old_key = scheme_hash_get(reverse_map, stack);
if (old_key) {
a = scheme_hash_get(rns, old_key);
if (just_simplify)
return SCHEME_CDR(a);
else
return SCHEME_CAR(a);
/* Double-check for equivalent list in table (after simplification): */
if (mt && mt->pass) {
/* No need to check for later passed, since mt->same_map
covers the equivalence. */
} else {
if (mt) {
reverse_map = mt->reverse_map;
} else {
reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined);
}
if (!reverse_map) {
reverse_map = scheme_make_hash_table_equal();
if (mt)
mt->reverse_map = reverse_map;
else
scheme_hash_set(rns, scheme_undefined, (Scheme_Object *)reverse_map);
}
old_key = scheme_hash_get(reverse_map, stack);
if (old_key) {
if (just_simplify) {
return scheme_hash_get(rns, old_key);
} else {
a = scheme_marshal_lookup(mt, old_key);
scheme_marshal_using_key(mt, old_key);
if (!mt->same_map) {
Scheme_Hash_Table *same_map;
same_map = scheme_make_hash_table(SCHEME_hash_ptr);
mt->same_map = same_map;
}
scheme_hash_set(mt->same_map, w_in, old_key);
/* nevermind references that we saw when creating `stack': */
scheme_marshal_pop_refs(mt, 0);
return a;
}
}
scheme_hash_set(reverse_map, stack, w_in);
}
/* Create a key for this wrap set: */
a = scheme_make_integer(rns->count);
scheme_hash_set(rns, w_in, CONS(a, stack));
scheme_hash_set(reverse_map, stack, w_in);
if (mt) {
/* preserve references that we saw when creating `stack': */
scheme_marshal_pop_refs(mt, 1);
}
if (just_simplify)
/* Remember this wrap set: */
if (just_simplify) {
scheme_hash_set(rns, w_in, stack);
return stack;
else
return CONS(a, stack);
} else {
return scheme_marshal_wrap_set(mt, w_in, stack);
}
}
/*========================================================================*/
@ -4206,27 +4267,27 @@ static void lift_common_wraps(Scheme_Object *l, Scheme_Object *common_wraps, int
static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
Scheme_Hash_Table **ht,
int with_marks,
Scheme_Hash_Table *rns);
Scheme_Marshal_Tables *mt);
static Scheme_Object *syntax_to_datum_k(void)
{
Scheme_Thread *p = scheme_current_thread;
Scheme_Object *o = (Scheme_Object *)p->ku.k.p1;
Scheme_Hash_Table **ht = (Scheme_Hash_Table **)p->ku.k.p2;
Scheme_Hash_Table *rns = (Scheme_Hash_Table *)p->ku.k.p3;
Scheme_Marshal_Tables *mt = (Scheme_Marshal_Tables *)p->ku.k.p3;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
return syntax_to_datum_inner(o, ht, p->ku.k.i1, rns);
return syntax_to_datum_inner(o, ht, p->ku.k.i1, mt);
}
#endif
static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
Scheme_Hash_Table **ht,
int with_marks,
Scheme_Hash_Table *rns)
Scheme_Marshal_Tables *mt)
{
Scheme_Stx *stx = (Scheme_Stx *)o;
Scheme_Object *ph, *v, *result, *converted_wraps = NULL;
@ -4239,7 +4300,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
p->ku.k.p1 = (void *)o;
p->ku.k.p2 = (void *)ht;
p->ku.k.i1 = with_marks;
p->ku.k.p3 = (void *)rns;
p->ku.k.p3 = (void *)mt;
return scheme_handle_stack_overflow(syntax_to_datum_k);
}
}
@ -4289,7 +4350,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
cnt++;
a = syntax_to_datum_inner(SCHEME_CAR(v), ht, with_marks, rns);
a = syntax_to_datum_inner(SCHEME_CAR(v), ht, with_marks, mt);
p = CONS(a, scheme_null);
@ -4312,13 +4373,13 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
}
}
if (!SCHEME_NULLP(v)) {
v = syntax_to_datum_inner(v, ht, with_marks, rns);
v = syntax_to_datum_inner(v, ht, with_marks, mt);
SCHEME_CDR(last) = v;
if (with_marks) {
v = extract_for_common_wrap(v, 1, 0);
if (v && SAME_OBJ(common_wraps, v)) {
converted_wraps = wraps_to_datum(stx->wraps, rns, 0);
converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0);
if (SAME_OBJ(common_wraps, converted_wraps))
lift_common_wraps(first, common_wraps, cnt, 1);
else
@ -4336,7 +4397,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
first = scheme_make_pair(scheme_make_integer(cnt), first);
}
} else if (with_marks && SCHEME_TRUEP(common_wraps)) {
converted_wraps = wraps_to_datum(stx->wraps, rns, 0);
converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0);
if (SAME_OBJ(common_wraps, converted_wraps))
lift_common_wraps(first, common_wraps, cnt, 0);
else
@ -4349,7 +4410,7 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
result = first;
} else if (SCHEME_BOXP(v)) {
v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), ht, with_marks, rns);
v = syntax_to_datum_inner(SCHEME_BOX_VAL(v), ht, with_marks, mt);
result = scheme_box(v);
} else if (SCHEME_VECTORP(v)) {
int size = SCHEME_VEC_SIZE(v), i;
@ -4358,21 +4419,21 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
r = scheme_make_vector(size, NULL);
for (i = 0; i < size; i++) {
a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], ht, with_marks, rns);
a = syntax_to_datum_inner(SCHEME_VEC_ELS(v)[i], ht, with_marks, mt);
SCHEME_VEC_ELS(r)[i] = a;
}
result = r;
#ifdef STX_DEBUG
} else if ((with_marks == 1) && SCHEME_SYMBOLP(v)) {
result = CONS(v, stx->wraps); /* wraps_to_datum(stx->wraps, rns, 0)); */
result = CONS(v, stx->wraps); /* wraps_to_datum(stx->wraps, mt, 0)); */
#endif
} else
result = v;
if (with_marks > 1) {
if (!converted_wraps)
converted_wraps = wraps_to_datum(stx->wraps, rns, 0);
converted_wraps = wraps_to_datum(stx->wraps, mt, NULL, 0);
result = CONS(result, converted_wraps);
if (stx->certs) {
Scheme_Object *cert_marks = scheme_null, *icert_marks = scheme_null;
@ -4410,37 +4471,40 @@ static Scheme_Object *syntax_to_datum_inner(Scheme_Object *o,
}
Scheme_Object *scheme_syntax_to_datum(Scheme_Object *stx, int with_marks,
Scheme_Hash_Table *rns)
Scheme_Marshal_Tables *mt)
{
Scheme_Hash_Table *ht = NULL;
Scheme_Object *v;
v = syntax_to_datum_inner(stx, &ht, with_marks, rns);
if (mt)
scheme_marshal_push_refs(mt);
if (with_marks > 1) {
if (SCHEME_PAIRP(v)
&& SCHEME_SYMBOLP(SCHEME_CAR(v))
&& SCHEME_INTP(SCHEME_CDR(v))) {
/* A symbol+wrap combination is likely to be used multiple
times. This is a relatively minor optimization in .zo size,
since v is already fairly compact, but it also avoids
allocating extra syntax objects at load time. */
Scheme_Hash_Table *reverse_map;
Scheme_Object *code;
reverse_map = (Scheme_Hash_Table *)scheme_hash_get(rns, scheme_undefined);
if (reverse_map) {
code = scheme_hash_get(reverse_map, v);
if (code) {
return code;
} else {
code = scheme_make_integer(rns->count);
scheme_hash_set(rns, code, v);
scheme_hash_set(reverse_map, v, code);
v = scheme_make_vector(2, v);
SCHEME_VEC_ELS(v)[1] = code;
}
}
v = syntax_to_datum_inner(stx, &ht, with_marks, mt);
if (mt) {
/* A symbol+wrap combination is likely to be used multiple
times. This is a relatively minor optimization in .zo size,
since v is already fairly compact, but it also avoids
allocating extra syntax objects at load time. For consistency,
we try to reuse all combinations. */
Scheme_Hash_Table *top_map;
Scheme_Object *key;
top_map = mt->top_map;
if (!top_map) {
top_map = scheme_make_hash_table_equal();
mt->top_map = top_map;
}
key = scheme_hash_get(top_map, v);
if (key) {
scheme_marshal_pop_refs(mt, 0);
v = scheme_marshal_lookup(mt, key);
scheme_marshal_using_key(mt, key);
} else {
scheme_hash_set(top_map, stx, v);
v = scheme_marshal_wrap_set(mt, stx, v);
scheme_marshal_pop_refs(mt, 1);
}
}
@ -4526,7 +4590,7 @@ int scheme_syntax_is_graph(Scheme_Object *stx)
/* datum->wraps */
/*========================================================================*/
static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Hash_Table *rns)
static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Unmarshal_Tables *ut)
{
Scheme_Object *n, *a = _a;
@ -4536,7 +4600,7 @@ static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Hash_Table *rns)
a = scheme_intern_symbol(scheme_number_to_string(10, a));
/* Picked a mapping yet? */
n = scheme_hash_get(rns, a);
n = scheme_hash_get(ut->rns, a);
if (!n) {
/* Map marshaled mark to a new mark. */
n = scheme_new_mark();
@ -4544,7 +4608,7 @@ static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Hash_Table *rns)
/* Map negative mark to negative mark: */
n = negate_mark(n);
}
scheme_hash_set(rns, a, n);
scheme_hash_set(ut->rns, a, n);
}
/* Really a mark? */
@ -4557,33 +4621,33 @@ static Scheme_Object *unmarshal_mark(Scheme_Object *_a, Scheme_Hash_Table *rns)
#define return_NULL return NULL
static Scheme_Object *datum_to_wraps(Scheme_Object *w,
Scheme_Hash_Table *rns)
Scheme_Unmarshal_Tables *ut)
{
Scheme_Object *a, *wraps_key;
int stack_size;
Scheme_Object *a, *wraps_key, *local_key;
int stack_size, decoded;
Wrap_Chunk *wc;
/* rns maps numbers (table indices) to renaming tables, and negative
/* ut->rns maps numbers (table indices) to renaming tables, and negative
numbers (negated fixnum marks) and symbols (interned marks) to marks.*/
/* This function has to be defensive, since `w' can originate in
untrusted .zo bytecodes. Return NULL for bad wraps. */
if (SCHEME_INTP(w)) {
w = scheme_hash_get(rns, w);
if (!w || !SCHEME_LISTP(w)) /* list => a wrap, as opposed to a mark, etc. */
wraps_key = w;
w = scheme_unmarshal_wrap_get(ut, wraps_key, &decoded);
if (decoded && (!w || !SCHEME_LISTP(w))) /* list => a wrap, as opposed to a mark, etc. */
return_NULL;
return w;
if (decoded)
return w;
} else {
/* not shared */
wraps_key = NULL;
}
if (!SCHEME_PAIRP(w)) return_NULL;
wraps_key = SCHEME_CAR(w);
w = SCHEME_CDR(w);
stack_size = scheme_proper_list_length(w);
if (stack_size < 1) {
scheme_hash_set(rns, wraps_key, scheme_null);
scheme_unmarshal_wrap_set(ut, wraps_key, scheme_null);
return scheme_null;
} else if (stack_size < 2) {
wc = NULL;
@ -4599,18 +4663,26 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
a = SCHEME_CAR(w);
if (SCHEME_NUMBERP(a)) {
/* Re-use rename table or env rename */
a = scheme_hash_get(rns, a);
if (!a || SCHEME_LISTP(a)) /* list => a whole wrap, no good as an element */
local_key = a;
a = scheme_unmarshal_wrap_get(ut, local_key, &decoded);
if (decoded && (!a || SCHEME_LISTP(a))) /* list => a whole wrap, no good as an element */
return_NULL;
} else {
/* Not shared */
local_key = NULL;
decoded = 0;
}
if (decoded) {
/* done */
} else if (SCHEME_PAIRP(a)
&& SCHEME_NULLP(SCHEME_CDR(a))
&& SCHEME_NUMBERP(SCHEME_CAR(a))) {
/* Mark */
a = unmarshal_mark(SCHEME_CAR(a), rns);
a = unmarshal_mark(SCHEME_CAR(a), ut);
if (!a) return_NULL;
} else if (SCHEME_VECTORP(a)) {
/* A (simplified) rename table. First element is the key. */
Scheme_Object *local_key;
/* A (simplified) rename table. */
int i = SCHEME_VEC_SIZE(a);
/* Make sure that it's a well-formed rename table. */
@ -4623,8 +4695,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
}
/* It's ok: */
local_key = SCHEME_VEC_ELS(a)[0];
scheme_hash_set(rns, local_key, a);
scheme_unmarshal_wrap_set(ut, local_key, a);
} else if (SCHEME_PAIRP(a)) {
/* A rename table:
- ([#t] <index-num> <phase-num> <bool> [unmarshal] #(<table-elem> ...)
@ -4633,15 +4704,12 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
- <exname> <modname>
- <exname> (<modname> . <defname>)
*/
Scheme_Object *local_key, *mns;
Scheme_Object *mns;
Module_Renames *mrn;
Scheme_Object *p, *key;
int plus_kernel, i, count, kind;
long phase;
local_key = SCHEME_CAR(a);
a = SCHEME_CDR(a);
if (!SCHEME_PAIRP(a)) return_NULL;
/* Convert list to rename table: */
@ -4676,37 +4744,37 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
Scheme_Object *ml = a, *mli;
while (SCHEME_PAIRP(ml)) {
mli = SCHEME_CAR(ml);
if (!SCHEME_PAIRP(mli)) return NULL;
if (!SCHEME_PAIRP(mli)) return_NULL;
/* A module path index: */
p = SCHEME_CAR(mli);
if (!(SCHEME_SYMBOLP(p)
|| SAME_TYPE(SCHEME_TYPE(p), scheme_module_index_type)))
return NULL;
return_NULL;
mli = SCHEME_CDR(mli);
if (!SCHEME_PAIRP(mli)) return NULL;
if (!SCHEME_PAIRP(mli)) return_NULL;
/* A list of symbols: */
p = SCHEME_CAR(mli);
while (SCHEME_PAIRP(p)) {
if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return NULL;
if (!SCHEME_SYMBOLP(SCHEME_CAR(p))) return_NULL;
p = SCHEME_CDR(p);
}
if (!SCHEME_NULLP(p)) return NULL;
if (!SCHEME_NULLP(p)) return_NULL;
/* #f or a symbol: */
p = SCHEME_CDR(mli);
if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return NULL;
if (!SCHEME_SYMBOLP(p) && !SCHEME_FALSEP(p)) return_NULL;
ml = SCHEME_CDR(ml);
}
if (!SCHEME_NULLP(ml)) return NULL;
if (!SCHEME_NULLP(ml)) return_NULL;
mrn->unmarshal_info = a;
if (SCHEME_PAIRP(a))
mrn->needs_unmarshal = 1;
if (!SCHEME_PAIRP(mns)) return NULL;
if (!SCHEME_PAIRP(mns)) return_NULL;
a = SCHEME_CAR(mns);
mns = SCHEME_CDR(mns);
}
@ -4777,7 +4845,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
klast = NULL;
a = SCHEME_CAR(a);
if (SCHEME_MARKP(a)) {
kfirst = unmarshal_mark(a, rns);
kfirst = unmarshal_mark(a, ut);
} else {
Scheme_Object *bdg = NULL;
@ -4789,7 +4857,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
}
for (; SCHEME_PAIRP(a); a = SCHEME_CDR(a)) {
kp = CONS(unmarshal_mark(SCHEME_CAR(a), rns), scheme_null);
kp = CONS(unmarshal_mark(SCHEME_CAR(a), ut), scheme_null);
if (!klast)
kfirst = kp;
else
@ -4798,7 +4866,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
}
if (!SCHEME_NULLP(a)) {
if (bdg && SCHEME_MARKP(a) && SCHEME_NULLP(kfirst))
kfirst = unmarshal_mark(a, rns);
kfirst = unmarshal_mark(a, ut);
else
return_NULL;
}
@ -4823,7 +4891,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
mrn->marked_names = ht;
}
scheme_hash_set(rns, local_key, (Scheme_Object *)mrn);
scheme_unmarshal_wrap_set(ut, local_key, (Scheme_Object *)mrn);
a = (Scheme_Object *)mrn;
} else if (SAME_OBJ(a, scheme_true)) {
@ -4865,7 +4933,7 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
a = (Scheme_Object *)wc;
a = CONS(a, scheme_null);
scheme_hash_set(rns, wraps_key, a);
scheme_unmarshal_wrap_set(ut, wraps_key, a);
return a;
}
@ -4877,11 +4945,14 @@ static Scheme_Object *datum_to_wraps(Scheme_Object *w,
#ifdef DO_STACK_CHECK
static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
Scheme_Unmarshal_Tables *ut,
Scheme_Stx *stx_src,
Scheme_Stx *stx_wraps,
Scheme_Hash_Table *ht);
Scheme_Hash_Table *ht);
Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, Scheme_Stx *stx_wraps, int *bad)
Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks,
Scheme_Unmarshal_Tables *ut,
Scheme_Stx *stx_wraps, int *bad)
{
/* Need to convert a list of marks to certs */
Scheme_Cert *certs = NULL;
@ -4895,7 +4966,7 @@ Scheme_Object *cert_marks_to_certs(Scheme_Object *cert_marks, Scheme_Stx *stx_wr
*bad = 1;
return_NULL;
}
a = unmarshal_mark(a, (Scheme_Hash_Table *)stx_wraps);
a = unmarshal_mark(a, ut);
if (!a) { *bad = 1; return_NULL; }
cert_marks = SCHEME_CDR(cert_marks);
@ -4930,17 +5001,20 @@ static Scheme_Object *datum_to_syntax_k(void)
Scheme_Stx *stx_src = (Scheme_Stx *)p->ku.k.p2;
Scheme_Stx *stx_wraps = (Scheme_Stx *)p->ku.k.p3;
Scheme_Hash_Table *ht = (Scheme_Hash_Table *)p->ku.k.p4;
Scheme_Unmarshal_Tables *ut = (Scheme_Unmarshal_Tables *)p->ku.k.p5;
p->ku.k.p1 = NULL;
p->ku.k.p2 = NULL;
p->ku.k.p3 = NULL;
p->ku.k.p4 = NULL;
p->ku.k.p5 = NULL;
return datum_to_syntax_inner(o, stx_src, stx_wraps, ht);
return datum_to_syntax_inner(o, ut, stx_src, stx_wraps, ht);
}
#endif
static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
Scheme_Unmarshal_Tables *ut,
Scheme_Stx *stx_src,
Scheme_Stx *stx_wraps, /* or rename table, or boxed precomputed wrap */
Scheme_Hash_Table *ht)
@ -4960,6 +5034,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
p->ku.k.p2 = (void *)stx_src;
p->ku.k.p3 = (void *)stx_wraps;
p->ku.k.p4 = (void *)ht;
p->ku.k.p5 = (void *)ut;
return scheme_handle_stack_overflow(datum_to_syntax_k);
}
}
@ -4985,7 +5060,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
}
}
if (SCHEME_HASHTP(stx_wraps)) {
if (ut && !SCHEME_BOXP(stx_wraps)) {
if (SCHEME_VECTORP(o)) {
/* This one has certs */
if (SCHEME_VEC_SIZE(o) == 2) {
@ -5026,7 +5101,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
/* Resolve wraps now, and then share it with
all nested objects (as indicated by a box
for stx_wraps). */
wraps = datum_to_wraps(wraps, (Scheme_Hash_Table *)stx_wraps);
wraps = datum_to_wraps(wraps, ut);
do_not_unpack_wraps = 1;
sub_stx_wraps = (Scheme_Stx *)scheme_box(wraps);
o = SCHEME_CDR(o);
@ -5048,7 +5123,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
}
}
a = datum_to_syntax_inner(SCHEME_CAR(o), stx_src, sub_stx_wraps, ht);
a = datum_to_syntax_inner(SCHEME_CAR(o), ut, stx_src, sub_stx_wraps, ht);
if (!a) return_NULL;
p = scheme_make_immutable_pair(a, scheme_null);
@ -5063,7 +5138,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
--cnt;
}
if (!SCHEME_NULLP(o)) {
o = datum_to_syntax_inner(o, stx_src, sub_stx_wraps, ht);
o = datum_to_syntax_inner(o, ut, stx_src, sub_stx_wraps, ht);
if (!o) return_NULL;
SCHEME_CDR(last) = o;
}
@ -5071,7 +5146,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
result = first;
}
} else if (SCHEME_BOXP(o)) {
o = datum_to_syntax_inner(SCHEME_PTR_VAL(o), stx_src, stx_wraps, ht);
o = datum_to_syntax_inner(SCHEME_PTR_VAL(o), ut, stx_src, stx_wraps, ht);
if (!o) return_NULL;
result = scheme_box(o);
SCHEME_SET_BOX_IMMUTABLE(result);
@ -5082,7 +5157,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
result = scheme_make_vector(size, NULL);
for (i = 0; i < size; i++) {
a = datum_to_syntax_inner(SCHEME_VEC_ELS(o)[i], stx_src, stx_wraps, ht);
a = datum_to_syntax_inner(SCHEME_VEC_ELS(o)[i], ut, stx_src, stx_wraps, ht);
if (!a) return_NULL;
SCHEME_VEC_ELS(result)[i] = a;
}
@ -5100,7 +5175,7 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
if (wraps) {
if (!do_not_unpack_wraps) {
wraps = datum_to_wraps(wraps, (Scheme_Hash_Table *)stx_wraps);
wraps = datum_to_wraps(wraps, ut);
if (!wraps)
return_NULL;
}
@ -5121,12 +5196,12 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
|| SCHEME_NULLP(SCHEME_CAR(cert_marks)))) {
/* Have both active and inactive certs */
Scheme_Object *icerts;
certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), stx_wraps, &bad);
icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), stx_wraps, &bad);
certs = cert_marks_to_certs(SCHEME_CAR(cert_marks), ut, stx_wraps, &bad);
icerts = cert_marks_to_certs(SCHEME_CDR(cert_marks), ut, stx_wraps, &bad);
certs = scheme_make_raw_pair(certs, icerts);
} else {
/* Just active certs */
certs = cert_marks_to_certs(cert_marks, stx_wraps, &bad);
certs = cert_marks_to_certs(cert_marks, ut, stx_wraps, &bad);
}
if (bad)
return_NULL;
@ -5141,15 +5216,15 @@ static Scheme_Object *datum_to_syntax_inner(Scheme_Object *o,
return result;
}
Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
Scheme_Object *stx_src,
Scheme_Object *stx_wraps,
int can_graph, int copy_props)
static Scheme_Object *general_datum_to_syntax(Scheme_Object *o,
Scheme_Unmarshal_Tables *ut,
Scheme_Object *stx_src,
Scheme_Object *stx_wraps,
int can_graph, int copy_props)
/* If stx_wraps is a hash table, then `o' includes marks and certs.
If copy_props > 0, properties are copied from src.
If copy_props != 1 or 0, then certs are copied from src, too. */
{
Scheme_Hash_Table *ht;
Scheme_Object *v, *code = NULL;
@ -5164,28 +5239,29 @@ Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
else
ht = NULL;
if (SCHEME_HASHTP(stx_wraps)) {
if (ut) {
/* If o is just a number, look it up in the table. */
if (SCHEME_INTP(o))
return scheme_hash_get((Scheme_Hash_Table *)stx_wraps, o);
/* If it's a vector where the second element is a number, we'll need to hash. */
if (SCHEME_VECTORP(o)
&& (SCHEME_VEC_SIZE(o) == 2)
&& SCHEME_INTP(SCHEME_VEC_ELS(o)[1])) {
code = SCHEME_VEC_ELS(o)[1];
o = SCHEME_VEC_ELS(o)[0];
if (SCHEME_INTP(o)) {
int decoded;
v = scheme_unmarshal_wrap_get(ut, o, &decoded);
if (!decoded) {
code = o;
o = v;
} else
return v;
}
}
v = datum_to_syntax_inner(o,
(Scheme_Stx *)stx_src,
ut,
(Scheme_Stx *)stx_src,
(Scheme_Stx *)stx_wraps,
ht);
if (!v) return_NULL; /* only happens with bad wraps from a bad .zo */
if (code) {
scheme_hash_set((Scheme_Hash_Table *)stx_wraps, code, v);
scheme_unmarshal_wrap_set(ut, code, v);
}
if (ht)
@ -5206,6 +5282,21 @@ Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
return v;
}
Scheme_Object *scheme_datum_to_syntax(Scheme_Object *o,
Scheme_Object *stx_src,
Scheme_Object *stx_wraps,
int can_graph, int copy_props)
{
return general_datum_to_syntax(o, NULL, stx_src, stx_wraps, can_graph, copy_props);
}
Scheme_Object *scheme_unmarshal_datum_to_syntax(Scheme_Object *o,
struct Scheme_Unmarshal_Tables *ut,
int can_graph)
{
return general_datum_to_syntax(o, ut, scheme_false, scheme_false, can_graph, 0);
}
/*========================================================================*/
/* simplify */
/*========================================================================*/
@ -5264,7 +5355,7 @@ static void simplify_syntax_inner(Scheme_Object *o,
scheme_stx_content((Scheme_Object *)stx);
if (rns) {
v = wraps_to_datum(stx->wraps, rns, 1);
v = wraps_to_datum(stx->wraps, NULL, rns, 1);
stx->wraps = v;
}

132
src/mzscheme/src/stypes.h
View File

@ -155,74 +155,78 @@ enum {
scheme_raw_pair_type, /* 137 */
scheme_prompt_type, /* 138 */
scheme_prompt_tag_type, /* 139 */
scheme_delay_syntax_type, /* 140 */
#ifdef MZTAG_REQUIRED
_scheme_last_normal_type_, /* 140 */
_scheme_last_normal_type_, /* 141 */
scheme_rt_weak_array, /* 141 */
scheme_rt_weak_array, /* 142 */
scheme_rt_comp_env, /* 142 */
scheme_rt_constant_binding, /* 143 */
scheme_rt_resolve_info, /* 144 */
scheme_rt_optimize_info, /* 145 */
scheme_rt_compile_info, /* 146 */
scheme_rt_cont_mark, /* 147 */
scheme_rt_saved_stack, /* 148 */
scheme_rt_reply_item, /* 149 */
scheme_rt_closure_info, /* 150 */
scheme_rt_overflow, /* 151 */
scheme_rt_overflow_jmp, /* 152 */
scheme_rt_meta_cont, /* 153 */
scheme_rt_dyn_wind_cell, /* 154 */
scheme_rt_dyn_wind_info, /* 155 */
scheme_rt_dyn_wind, /* 156 */
scheme_rt_dup_check, /* 157 */
scheme_rt_thread_memory, /* 158 */
scheme_rt_input_file, /* 159 */
scheme_rt_input_fd, /* 160 */
scheme_rt_oskit_console_input, /* 161 */
scheme_rt_tested_input_file, /* 162 */
scheme_rt_tested_output_file, /* 163 */
scheme_rt_indexed_string, /* 164 */
scheme_rt_output_file, /* 165 */
scheme_rt_load_handler_data, /* 166 */
scheme_rt_pipe, /* 167 */
scheme_rt_beos_process, /* 168 */
scheme_rt_system_child, /* 169 */
scheme_rt_tcp, /* 170 */
scheme_rt_write_data, /* 171 */
scheme_rt_tcp_select_info, /* 172 */
scheme_rt_namespace_option, /* 173 */
scheme_rt_param_data, /* 174 */
scheme_rt_will, /* 175 */
scheme_rt_will_registration, /* 176 */
scheme_rt_struct_proc_info, /* 177 */
scheme_rt_linker_name, /* 178 */
scheme_rt_param_map, /* 179 */
scheme_rt_finalization, /* 180 */
scheme_rt_finalizations, /* 181 */
scheme_rt_cpp_object, /* 182 */
scheme_rt_cpp_array_object, /* 183 */
scheme_rt_stack_object, /* 184 */
scheme_rt_preallocated_object, /* 185 */
scheme_thread_hop_type, /* 186 */
scheme_rt_srcloc, /* 187 */
scheme_rt_evt, /* 188 */
scheme_rt_syncing, /* 189 */
scheme_rt_comp_prefix, /* 190 */
scheme_rt_user_input, /* 191 */
scheme_rt_user_output, /* 192 */
scheme_rt_compact_port, /* 193 */
scheme_rt_read_special_dw, /* 194 */
scheme_rt_regwork, /* 195 */
scheme_rt_buf_holder, /* 196 */
scheme_rt_parameterization, /* 197 */
scheme_rt_print_params, /* 198 */
scheme_rt_read_params, /* 199 */
scheme_rt_native_code, /* 200 */
scheme_rt_native_code_plus_case, /* 201 */
scheme_rt_jitter_data, /* 202 */
scheme_rt_module_exports, /* 203 */
scheme_rt_comp_env, /* 143 */
scheme_rt_constant_binding, /* 144 */
scheme_rt_resolve_info, /* 145 */
scheme_rt_optimize_info, /* 146 */
scheme_rt_compile_info, /* 147 */
scheme_rt_cont_mark, /* 148 */
scheme_rt_saved_stack, /* 149 */
scheme_rt_reply_item, /* 150 */
scheme_rt_closure_info, /* 151 */
scheme_rt_overflow, /* 152 */
scheme_rt_overflow_jmp, /* 153 */
scheme_rt_meta_cont, /* 154 */
scheme_rt_dyn_wind_cell, /* 155 */
scheme_rt_dyn_wind_info, /* 156 */
scheme_rt_dyn_wind, /* 157 */
scheme_rt_dup_check, /* 158 */
scheme_rt_thread_memory, /* 159 */
scheme_rt_input_file, /* 160 */
scheme_rt_input_fd, /* 161 */
scheme_rt_oskit_console_input, /* 162 */
scheme_rt_tested_input_file, /* 163 */
scheme_rt_tested_output_file, /* 164 */
scheme_rt_indexed_string, /* 165 */
scheme_rt_output_file, /* 166 */
scheme_rt_load_handler_data, /* 167 */
scheme_rt_pipe, /* 168 */
scheme_rt_beos_process, /* 169 */
scheme_rt_system_child, /* 170 */
scheme_rt_tcp, /* 171 */
scheme_rt_write_data, /* 172 */
scheme_rt_tcp_select_info, /* 173 */
scheme_rt_namespace_option, /* 174 */
scheme_rt_param_data, /* 175 */
scheme_rt_will, /* 176 */
scheme_rt_will_registration, /* 177 */
scheme_rt_struct_proc_info, /* 178 */
scheme_rt_linker_name, /* 179 */
scheme_rt_param_map, /* 180 */
scheme_rt_finalization, /* 181 */
scheme_rt_finalizations, /* 182 */
scheme_rt_cpp_object, /* 183 */
scheme_rt_cpp_array_object, /* 184 */
scheme_rt_stack_object, /* 185 */
scheme_rt_preallocated_object, /* 186 */
scheme_thread_hop_type, /* 187 */
scheme_rt_srcloc, /* 188 */
scheme_rt_evt, /* 189 */
scheme_rt_syncing, /* 190 */
scheme_rt_comp_prefix, /* 191 */
scheme_rt_user_input, /* 192 */
scheme_rt_user_output, /* 193 */
scheme_rt_compact_port, /* 194 */
scheme_rt_read_special_dw, /* 195 */
scheme_rt_regwork, /* 196 */
scheme_rt_buf_holder, /* 197 */
scheme_rt_parameterization, /* 198 */
scheme_rt_print_params, /* 199 */
scheme_rt_read_params, /* 200 */
scheme_rt_native_code, /* 201 */
scheme_rt_native_code_plus_case, /* 202 */
scheme_rt_jitter_data, /* 203 */
scheme_rt_module_exports, /* 204 */
scheme_rt_delay_load_info, /* 205 */
scheme_rt_marshal_info, /* 206 */
scheme_rt_unmarshal_info, /* 207 */
#endif
_scheme_last_type_

374
src/mzscheme/src/syntax.c
View File

@ -103,7 +103,6 @@ static Scheme_Object *apply_values_execute(Scheme_Object *data);
static Scheme_Object *splice_execute(Scheme_Object *data);
static Scheme_Object *bangboxenv_execute(Scheme_Object *data);
static Scheme_Object *bangboxvalue_execute(Scheme_Object *data);
static Scheme_Object *define_values_optimize(Scheme_Object *data, Optimize_Info *info);
static Scheme_Object *ref_optimize(Scheme_Object *data, Optimize_Info *info);
@ -177,10 +176,6 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts);
static Scheme_Object *define_values_jit(Scheme_Object *data);
static Scheme_Object *ref_jit(Scheme_Object *data);
@ -191,7 +186,7 @@ static Scheme_Object *case_lambda_jit(Scheme_Object *expr);
static Scheme_Object *begin0_jit(Scheme_Object *data);
static Scheme_Object *apply_values_jit(Scheme_Object *data);
static Scheme_Object *splice_jit(Scheme_Object *data);
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data);
static Scheme_Object *bangboxenv_jit(Scheme_Object *data);
static Scheme_Object *expand_lam(int argc, Scheme_Object **argv);
@ -313,12 +308,8 @@ scheme_init_syntax (Scheme_Env *env)
scheme_register_syntax(BOXENV_EXPD,
NULL, NULL, bangboxenv_validate,
bangboxenv_execute, NULL,
bangboxenv_execute, bangboxenv_jit,
NULL, NULL, 1);
scheme_register_syntax(BOXVAL_EXPD,
NULL, NULL, bangboxvalue_validate,
bangboxvalue_execute, bangboxvalue_jit,
NULL, NULL, 2);
scheme_install_type_writer(scheme_let_value_type, write_let_value);
scheme_install_type_reader(scheme_let_value_type, read_let_value);
@ -662,14 +653,16 @@ void scheme_install_macro(Scheme_Bucket *b, Scheme_Object *v)
}
static Scheme_Object *
define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
define_execute(Scheme_Object *vec, int delta, int defmacro,
Resolve_Prefix *rp, Scheme_Env *dm_env)
{
Scheme_Object *l, *name, *macro;
Scheme_Object *name, *macro, *vals, *var;
int i, g, show_any;
Scheme_Bucket *b;
Scheme_Object **save_runstack = NULL;
vals = SCHEME_VEC_ELS(vec)[0];
if (dm_env) {
scheme_prepare_exp_env(dm_env);
@ -685,9 +678,9 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
}
if (SAME_OBJ(vals, SCHEME_MULTIPLE_VALUES)) {
Scheme_Object *v, **values;
Scheme_Object **values;
for (v = vars, i = 0; SCHEME_PAIRP(v); i++, v = SCHEME_CDR(v)) {}
i = SCHEME_VEC_SIZE(vec) - delta;
g = scheme_current_thread->ku.multiple.count;
if (i == g) {
@ -695,9 +688,10 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
scheme_current_thread->ku.multiple.array = NULL;
if (SAME_OBJ(values, scheme_current_thread->values_buffer))
scheme_current_thread->values_buffer = NULL;
for (i = 0; i < g; i++, vars = SCHEME_CDR(vars)) {
for (i = 0; i < g; i++) {
var = SCHEME_VEC_ELS(vec)[i+delta];
if (dm_env) {
b = scheme_global_keyword_bucket(SCHEME_CAR(vars), dm_env);
b = scheme_global_keyword_bucket(var, dm_env);
macro = scheme_alloc_small_object();
macro->type = scheme_macro_type;
@ -707,13 +701,13 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
} else {
Scheme_Object **toplevels;
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(SCHEME_CAR(vars))];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(SCHEME_CAR(vars))];
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
scheme_set_global_bucket("define-values", b, values[i], 1);
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(SCHEME_CAR(vars)) & SCHEME_TOPLEVEL_CONST) {
if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
}
}
@ -726,9 +720,10 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
if (SAME_OBJ(scheme_current_thread->ku.multiple.array, scheme_current_thread->values_buffer))
scheme_current_thread->values_buffer = NULL;
} else if (SCHEME_PAIRP(vars) && SCHEME_NULLP(SCHEME_CDR(vars))) {
} else if (SCHEME_VEC_SIZE(vec) == delta + 1) { /* => single var */
var = SCHEME_VEC_ELS(vec)[delta];
if (dm_env) {
b = scheme_global_keyword_bucket(SCHEME_CAR(vars), dm_env);
b = scheme_global_keyword_bucket(var, dm_env);
macro = scheme_alloc_small_object();
macro->type = scheme_macro_type;
@ -738,13 +733,13 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
scheme_shadow(dm_env, (Scheme_Object *)b->key, 0);
} else {
Scheme_Object **toplevels;
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(SCHEME_CAR(vars))];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(SCHEME_CAR(vars))];
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
scheme_set_global_bucket("define-values", b, vals, 1);
scheme_shadow(((Scheme_Bucket_With_Home *)b)->home, (Scheme_Object *)b->key, 1);
if (SCHEME_TOPLEVEL_FLAGS(SCHEME_CAR(vars)) & SCHEME_TOPLEVEL_CONST) {
if (SCHEME_TOPLEVEL_FLAGS(var) & SCHEME_TOPLEVEL_CONST) {
((Scheme_Bucket_With_Flags *)b)->flags |= GLOB_IS_IMMUTATED;
}
@ -763,19 +758,19 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
if (dm_env && !g)
return scheme_void;
l = vars;
for (i = 0; SCHEME_PAIRP(l); i++, l = SCHEME_CDR(l)) {}
i = SCHEME_VEC_SIZE(vec) - delta;
show_any = i;
if (show_any) {
var = SCHEME_VEC_ELS(vec)[delta];
if (dm_env) {
b = scheme_global_keyword_bucket(SCHEME_CAR(vars), dm_env);
b = scheme_global_keyword_bucket(var, dm_env);
name = (Scheme_Object *)b->key;
} else {
Scheme_Object **toplevels;
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(SCHEME_CAR(vars))];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(SCHEME_CAR(vars))];
toplevels = (Scheme_Object **)MZ_RUNSTACK[SCHEME_TOPLEVEL_DEPTH(var)];
b = (Scheme_Bucket *)toplevels[SCHEME_TOPLEVEL_POS(var)];
name = (Scheme_Object *)b->key;
}
} else
@ -806,26 +801,41 @@ define_execute(Scheme_Object *vars, Scheme_Object *vals, int defmacro,
static Scheme_Object *
define_values_execute(Scheme_Object *data)
{
return define_execute(SCHEME_CAR(data), SCHEME_CDR(data), 0, NULL, NULL);
return define_execute(data, 1, 0, NULL, NULL);
}
static Scheme_Object *clone_vector(Scheme_Object *data, int skip)
{
Scheme_Object *naya;
int i, size;
size = SCHEME_VEC_SIZE(data);
naya = scheme_make_vector(size - skip, NULL);
for (i = skip; i < size; i++) {
SCHEME_VEC_ELS(naya)[i - skip] = SCHEME_VEC_ELS(data)[i];
}
return naya;
}
static Scheme_Object *define_values_jit(Scheme_Object *data)
{
Scheme_Object *orig = SCHEME_CDR(data), *naya, *vars;
vars = SCHEME_CAR(data);
Scheme_Object *orig = SCHEME_VEC_ELS(data)[0], *naya;
if (SAME_TYPE(SCHEME_TYPE(orig), scheme_unclosed_procedure_type)
&& SCHEME_PAIRP(vars)
&& SCHEME_NULLP(SCHEME_CDR(vars)))
naya = scheme_jit_closure(orig, SCHEME_CAR(vars));
&& (SCHEME_VEC_SIZE(data) == 2))
naya = scheme_jit_closure(orig, SCHEME_VEC_ELS(data)[1]);
else
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return scheme_make_pair(vars, naya);
else {
orig = naya;
naya = clone_vector(data, 0);
SCHEME_VEC_ELS(naya)[0] = orig;
return naya;
}
}
static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
@ -833,27 +843,25 @@ static void define_values_validate(Scheme_Object *data, Mz_CPort *port,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
Scheme_Object *vars, *val, *only_var;
int i, size;
Scheme_Object *val, *only_var;
if (!SCHEME_PAIRP(data))
if (!SCHEME_VECTORP(data))
scheme_ill_formed_code(port);
vars = SCHEME_CAR(data);
val = SCHEME_CDR(data);
val = SCHEME_VEC_ELS(data)[0];
size = SCHEME_VEC_SIZE(data);
if (SCHEME_PAIRP(vars) && SCHEME_NULLP(SCHEME_CDR(vars)))
only_var = SCHEME_CAR(vars);
if (size == 2)
only_var = SCHEME_VEC_ELS(data)[1];
else
only_var = NULL;
for (; SCHEME_PAIRP(vars); vars = SCHEME_CDR(vars)) {
scheme_validate_toplevel(SCHEME_CAR(vars), port, stack, ht, tls, depth, delta,
for (i = 1; i < size; i++) {
scheme_validate_toplevel(SCHEME_VEC_ELS(data)[i], port, stack, ht, tls, depth, delta,
num_toplevels, num_stxes, num_lifts,
1);
}
if (!SCHEME_NULLP(vars))
scheme_ill_formed_code(port);
if (only_var) {
int pos;
@ -908,8 +916,9 @@ define_values_optimize(Scheme_Object *data, Optimize_Info *info)
static Scheme_Object *
define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
{
long cnt = 0;
Scheme_Object *vars = SCHEME_CAR(data), *l, *a;
Scheme_Object *val = SCHEME_CDR(data);
Scheme_Object *val = SCHEME_CDR(data), *vec;
/* If this is a module-level definition: for each variable, if the
defined variable doesn't have SCHEME_TOPLEVEL_MUTATED, then
@ -924,18 +933,31 @@ define_values_resolve(Scheme_Object *data, Resolve_Info *rslv)
}
a = scheme_resolve_toplevel(rslv, a);
SCHEME_CAR(l) = a;
cnt++;
}
vec = scheme_make_vector(cnt + 1, NULL);
cnt = 1;
for (l = vars; !SCHEME_NULLP(l); l = SCHEME_CDR(l)) {
SCHEME_VEC_ELS(vec)[cnt++] = SCHEME_CAR(l);
}
val = scheme_resolve_expr(val, rslv);
SCHEME_VEC_ELS(vec)[0] = val;
return scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, cons(vars, val));
return scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, vec);
}
void scheme_resolve_lift_definition(Resolve_Info *info, Scheme_Object *var, Scheme_Object *rhs)
{
Scheme_Object *decl, *vec, *pr;
decl = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, cons(cons(var, scheme_null), rhs));
vec = scheme_make_vector(2, NULL);
SCHEME_VEC_ELS(vec)[0] = rhs;
SCHEME_VEC_ELS(vec)[1] = var;
decl = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, vec);
vec = info->lifts;
pr = cons(decl, SCHEME_VEC_ELS(vec)[0]);
SCHEME_VEC_ELS(vec)[0] = pr;
@ -2411,8 +2433,8 @@ case_lambda_expand(Scheme_Object *form, Scheme_Comp_Env *env, Scheme_Expand_Info
/* implicit set!s */
/**********************************************************************/
/* A bangboxenv step is inserted by the compilation of `lambda' forms
where an argument is set!ed in the function body. */
/* A bangboxenv step is inserted by the compilation of `lambda' and
`let' forms where an argument or bindings is set!ed in the body. */
Scheme_Object *bangboxenv_execute(Scheme_Object *data)
{
@ -2427,6 +2449,18 @@ Scheme_Object *bangboxenv_execute(Scheme_Object *data)
return _scheme_tail_eval(data);
}
static Scheme_Object *bangboxenv_jit(Scheme_Object *data)
{
Scheme_Object *orig, *naya;
orig = SCHEME_CDR(data);
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return cons(SCHEME_CAR(data), naya);
}
static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
@ -2442,85 +2476,6 @@ static void bangboxenv_validate(Scheme_Object *data, Mz_CPort *port,
NULL, 0);
}
/* A bangboxval step is inserted by the compilation of `let' forms
where the RHS is bound to a variable that will be set!ed. */
static Scheme_Object *
bangboxvalue_execute(Scheme_Object *data)
{
int pos, cnt;
Scheme_Object *val;
pos = SCHEME_INT_VAL(SCHEME_CAR(data));
data = SCHEME_CDR(data);
cnt = SCHEME_INT_VAL(SCHEME_CAR(data));
data = SCHEME_CDR(data);
val = _scheme_eval_linked_expr_multi(data);
if (SAME_OBJ(val, SCHEME_MULTIPLE_VALUES)) {
Scheme_Thread *p = scheme_current_thread;
if (cnt == p->ku.multiple.count) {
Scheme_Object **naya, **a;
int i;
a = p->ku.multiple.array;
if (SAME_OBJ(a, p->values_buffer))
p->values_buffer = NULL;
naya = MALLOC_N(Scheme_Object *, p->ku.multiple.count);
for (i = p->ku.multiple.count; i--; ) {
naya[i] = a[i];
}
{
Scheme_Object *eb;
eb = scheme_make_envunbox(naya[pos]);
naya[pos] = eb;
}
p->ku.multiple.array = naya;
}
} else if (cnt == 1)
val = scheme_make_envunbox(val);
return val;
}
static Scheme_Object *bangboxvalue_jit(Scheme_Object *data)
{
Scheme_Object *orig, *naya;
orig = SCHEME_CDR(data);
orig = SCHEME_CDR(orig);
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
return data;
else
return cons(SCHEME_CAR(data),
cons(SCHEME_CADR(data),
naya));
}
static void bangboxvalue_validate(Scheme_Object *data, Mz_CPort *port,
char *stack, Scheme_Hash_Table *ht, Scheme_Object **tls,
int depth, int letlimit, int delta,
int num_toplevels, int num_stxes, int num_lifts)
{
if (!SCHEME_PAIRP(data)
|| !SCHEME_PAIRP(SCHEME_CDR(data))
|| (SCHEME_INT_VAL(SCHEME_CADR(data)) < 0)
|| (SCHEME_INT_VAL(SCHEME_CADR(data)) <= SCHEME_INT_VAL(SCHEME_CAR(data))))
scheme_ill_formed_code(port);
scheme_validate_expr(port, SCHEME_CDR(SCHEME_CDR(data)), stack, ht, tls, depth, letlimit, delta,
num_toplevels, num_stxes, num_lifts,
NULL, 0);
}
/**********************************************************************/
/* let, let-values, letrec, etc. */
/**********************************************************************/
@ -2681,7 +2636,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
/* Special case: (let ([x E]) x) where E is lambda, case-lambda, or
a constant. (If we allowed arbitrary E here, it would affect the
tailness of E.) */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_local_type)
&& (((Scheme_Local *)clv->body)->position == 0)) {
@ -2714,7 +2669,7 @@ scheme_optimize_lets(Scheme_Object *form, Optimize_Info *info, int for_inline)
} else
rhs_info = body_info;
is_rec = SCHEME_LET_RECURSIVE(head);
is_rec = (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE);
if (is_rec)
all_simple = 0;
@ -2890,7 +2845,7 @@ scheme_optimize_lets_for_test(Scheme_Object *form, Optimize_Info *info)
/* Special case: (let ([x M]) (if x x N)), where x is not in N,
to (if M #t #f), since we're in a test position. */
if (!SCHEME_LET_RECURSIVE(head) && (head->count == 1) && (head->num_clauses == 1)) {
if (!(SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) && (head->count == 1) && (head->num_clauses == 1)) {
Scheme_Compiled_Let_Value *clv;
clv = (Scheme_Compiled_Let_Value *)head->body;
if (SAME_TYPE(SCHEME_TYPE(clv->body), scheme_branch_type)
@ -3003,10 +2958,10 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
Scheme_Let_Header *head = (Scheme_Let_Header *)form;
Scheme_Compiled_Let_Value *clv, *pre_body;
Scheme_Let_Value *lv, *last = NULL;
Scheme_Object *first = NULL, *body;
Scheme_Object *first = NULL, *body, *last_body = NULL;
Scheme_Letrec *letrec;
mzshort *skips, skips_fast[5];
Scheme_Object **lifted, *lifted_fast[5];
Scheme_Object **lifted, *lifted_fast[5], *boxes;
int i, pos, opos, rpos, recbox, num_rec_procs = 0, extra_alloc;
int rec_proc_nonapply = 0;
int max_let_depth = 0;
@ -3022,7 +2977,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
}
recbox = 0;
if (SCHEME_LET_RECURSIVE(head)) {
if (SCHEME_LET_FLAGS(head) & SCHEME_LET_RECURSIVE) {
/* Do we need to box vars in a letrec? */
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
@ -3063,7 +3018,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
if (recbox)
num_rec_procs = 0;
} else {
/* Sequence of single-value lets? */
/* Sequence of single-value, non-assigned lets? */
clv = (Scheme_Compiled_Let_Value *)head->body;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
if (clv->count != 1)
@ -3367,6 +3322,7 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
letrec = NULL;
/* Resolve values: */
boxes = scheme_null;
clv = (Scheme_Compiled_Let_Value *)head->body;
rpos = 0; opos = 0;
for (i = head->num_clauses; i--; clv = (Scheme_Compiled_Let_Value *)clv->body) {
@ -3396,9 +3352,12 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
lv = MALLOC_ONE_TAGGED(Scheme_Let_Value);
if (last)
last->body = (Scheme_Object *)lv;
else if (last_body)
SCHEME_CDR(last_body) = (Scheme_Object *)lv;
else
first = (Scheme_Object *)lv;
last = lv;
last_body = NULL;
lv->iso.so.type = scheme_let_value_type;
lv->value = expr;
@ -3414,13 +3373,24 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
for (j = lv->count; j--; ) {
if (!recbox
&& (scheme_resolve_info_flags(linfo, opos + j, &one_lifted) & SCHEME_INFO_BOXED)) {
Scheme_Object *sl;
/* See bangboxval... */
sl = scheme_make_syntax_resolved(BOXVAL_EXPD,
cons(scheme_make_integer(j),
cons(scheme_make_integer(lv->count),
lv->value)));
lv->value = sl;
GC_CAN_IGNORE Scheme_Object *pos;
pos = scheme_make_integer(lv->position + j);
if (SCHEME_LET_FLAGS(head) & (SCHEME_LET_STAR | SCHEME_LET_RECURSIVE)) {
/* For let* or a let*-like letrec, we need to insert the boxes after each evaluation. */
Scheme_Object *boxenv, *pr;
pr = scheme_make_pair(pos, scheme_false);
boxenv = scheme_make_syntax_resolved(BOXENV_EXPD, pr);
if (last)
last->body = boxenv;
else
SCHEME_CDR(last_body) = boxenv;
last = NULL;
last_body = pr;
} else {
/* For regular let, delay the boxing until all RHSs are
evaluated. */
boxes = scheme_make_pair(pos, boxes);
}
}
}
}
@ -3430,14 +3400,26 @@ scheme_resolve_lets(Scheme_Object *form, Resolve_Info *info)
/* Resolve body: */
body = scheme_resolve_expr(body, linfo);
while (SCHEME_PAIRP(boxes)) {
/* See bangboxenv... */
body = scheme_make_syntax_resolved(BOXENV_EXPD,
scheme_make_pair(SCHEME_CAR(boxes),
body));
boxes = SCHEME_CDR(boxes);
}
if (letrec) {
letrec->body = body;
if (last)
last->body = (Scheme_Object *)letrec;
else if (last_body)
SCHEME_CDR(last_body) = (Scheme_Object *)letrec;
else
first = (Scheme_Object *)letrec;
} else if (last)
last->body = body;
else if (last_body)
SCHEME_CDR(last_body) = body;
else
first = body;
@ -3678,7 +3660,8 @@ gen_let_syntax (Scheme_Object *form, Scheme_Comp_Env *origenv, char *formname,
head->body = first;
head->count = num_bindings;
head->num_clauses = num_clauses;
SCHEME_LET_RECURSIVE(head) = recursive;
SCHEME_LET_FLAGS(head) = ((recursive ? SCHEME_LET_RECURSIVE : 0)
| (star ? SCHEME_LET_STAR : 0));
first = (Scheme_Object *)head;
}
@ -4544,8 +4527,8 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx)
int depth;
Scheme_Comp_Env *rhs_env;
rp = (Resolve_Prefix *)SCHEME_CAR(form);
base_stack_depth = SCHEME_CADR(form);
rp = (Resolve_Prefix *)SCHEME_VEC_ELS(form)[1];
base_stack_depth = SCHEME_VEC_ELS(form)[2];
depth = SCHEME_INT_VAL(base_stack_depth) + rp->num_stxes + 1;
if (!scheme_check_runstack(depth)) {
@ -4553,8 +4536,7 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx)
if (!dm_env) {
/* Need to get env before we enlarge the runstack: */
form = SCHEME_CDDR(form);
dummy = SCHEME_CAR(form);
dummy = SCHEME_VEC_ELS(form)[3];
dm_env = scheme_environment_from_dummy(dummy);
}
p->ku.k.p2 = (Scheme_Object *)dm_env;
@ -4563,9 +4545,7 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx)
return (Scheme_Object *)scheme_enlarge_runstack(depth, define_syntaxes_execute_k);
}
form = SCHEME_CDDR(form);
dummy = SCHEME_CAR(form);
form = SCHEME_CDR(form);
dummy = SCHEME_VEC_ELS(form)[3];
rhs_env = scheme_new_comp_env(scheme_get_env(NULL), NULL, SCHEME_TOPLEVEL_FRAME);
@ -4573,7 +4553,7 @@ do_define_syntaxes_execute(Scheme_Object *form, Scheme_Env *dm_env, int for_stx)
dm_env = scheme_environment_from_dummy(dummy);
scheme_on_next_top(rhs_env, NULL, scheme_false, NULL, dm_env, dm_env->link_midx);
return define_execute(SCHEME_CAR(form), SCHEME_CDR(form), for_stx ? 2 : 1, rp, dm_env);
return define_execute(form, 4, for_stx ? 2 : 1, rp, dm_env);
}
static Scheme_Object *
@ -4590,28 +4570,16 @@ define_for_syntaxes_execute(Scheme_Object *form)
static Scheme_Object *do_define_syntaxes_jit(Scheme_Object *expr)
{
Scheme_Object *orig, *naya, *data = expr;
Scheme_Object *a, *ad, *add;
Scheme_Object *naya;
a = SCHEME_CAR(data);
data = SCHEME_CDR(data);
ad = SCHEME_CAR(data);
data = SCHEME_CDR(data);
add = SCHEME_CAR(data);
data = SCHEME_CDR(data);
orig = SCHEME_CDR(data);
naya = scheme_jit_expr(SCHEME_VEC_ELS(expr)[0]);
naya = scheme_jit_expr(orig);
if (SAME_OBJ(naya, orig))
if (SAME_OBJ(naya, expr))
return expr;
else {
return cons(a,
cons(ad,
cons(add,
cons(SCHEME_CAR(data),
naya))));
expr = clone_vector(expr, 0);
SCHEME_VEC_ELS(expr)[0] = naya;
return expr;
}
}
@ -4632,36 +4600,32 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
int for_stx)
{
Resolve_Prefix *rp;
Scheme_Object *names, *val, *base_stack_depth, *dummy;
Scheme_Object *name, *val, *base_stack_depth, *dummy;
int sdepth;
if (!SCHEME_PAIRP(data)
|| !SCHEME_PAIRP(SCHEME_CDR(data)))
if (!SCHEME_VECTORP(data)
|| (SCHEME_VEC_SIZE(data) < 4))
scheme_ill_formed_code(port);
rp = (Resolve_Prefix *)SCHEME_CAR(data);
base_stack_depth = SCHEME_CADR(data);
rp = (Resolve_Prefix *)SCHEME_VEC_ELS(data)[1];
base_stack_depth = SCHEME_VEC_ELS(data)[2];
sdepth = SCHEME_INT_VAL(base_stack_depth);
data = SCHEME_CDDR(data);
if (!SCHEME_PAIRP(data)
|| !SCHEME_PAIRP(SCHEME_CDR(data))
|| !SAME_TYPE(rp->so.type, scheme_resolve_prefix_type)
if (!SAME_TYPE(rp->so.type, scheme_resolve_prefix_type)
|| (sdepth < 0))
scheme_ill_formed_code(port);
dummy = SCHEME_CAR(data);
data = SCHEME_CDR(data);
names = SCHEME_CAR(data);
val = SCHEME_CDR(data);
dummy = SCHEME_VEC_ELS(data)[3];
if (!for_stx) {
for (; SCHEME_PAIRP(names); names = SCHEME_CDR(names)) {
if (!SCHEME_SYMBOLP(SCHEME_CAR(names)))
int i, size;
size = SCHEME_VEC_SIZE(data);
for (i = 4; i < size; i++) {
name = SCHEME_VEC_ELS(data)[i];
if (!SCHEME_SYMBOLP(name))
scheme_ill_formed_code(port);
}
if (!SCHEME_NULLP(names))
scheme_ill_formed_code(port);
}
scheme_validate_toplevel(dummy, port, stack, ht, tls, depth, delta,
@ -4669,10 +4633,12 @@ static void do_define_syntaxes_validate(Scheme_Object *data, Mz_CPort *port,
0);
if (!for_stx) {
scheme_validate_code(port, val, ht, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts);
scheme_validate_code(port, SCHEME_VEC_ELS(data)[0], ht, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts);
} else {
/* Make a fake `define-values' to check with respect to the exp-time stack */
val = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, cons(names, val));
val = clone_vector(data, 3);
SCHEME_VEC_ELS(val)[0] = SCHEME_VEC_ELS(data)[0];
val = scheme_make_syntax_resolved(DEFINE_VALUES_EXPD, val);
scheme_validate_code(port, val, ht, sdepth, rp->num_toplevels, rp->num_stxes, rp->num_lifts);
}
}
@ -4732,8 +4698,9 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In
{
Comp_Prefix *cp;
Resolve_Prefix *rp;
Scheme_Object *names, *val, *base_stack_depth, *dummy;
Scheme_Object *names, *val, *base_stack_depth, *dummy, *vec;
Resolve_Info *einfo;
int len;
cp = (Comp_Prefix *)SCHEME_CAR(data);
data = SCHEME_CDR(data);
@ -4755,11 +4722,22 @@ static Scheme_Object *do_define_syntaxes_resolve(Scheme_Object *data, Resolve_In
base_stack_depth = scheme_make_integer(einfo->max_let_depth);
len = scheme_list_length(names);
vec = scheme_make_vector(len + 4, NULL);
SCHEME_VEC_ELS(vec)[0] = val;
SCHEME_VEC_ELS(vec)[1] = (Scheme_Object *)rp;
SCHEME_VEC_ELS(vec)[2] = base_stack_depth;
SCHEME_VEC_ELS(vec)[3] = dummy;
len = 4;
while (SCHEME_PAIRP(names)) {
SCHEME_VEC_ELS(vec)[len++] = SCHEME_CAR(names);
names = SCHEME_CDR(names);
}
return scheme_make_syntax_resolved((for_stx ? DEFINE_FOR_SYNTAX_EXPD : DEFINE_SYNTAX_EXPD),
cons((Scheme_Object *)rp,
cons(base_stack_depth,
cons(dummy,
cons(names, val)))));
vec);
}
static Scheme_Object *define_syntaxes_resolve(Scheme_Object *data, Resolve_Info *info)

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

@ -5920,6 +5920,8 @@ static void make_initial_config(Scheme_Thread *p)
init_param(cells, paramz, MZCONFIG_CAN_READ_QUASI, scheme_true);
init_param(cells, paramz, MZCONFIG_READ_DECIMAL_INEXACT, scheme_true);
init_param(cells, paramz, MZCONFIG_CAN_READ_READER, scheme_false);
init_param(cells, paramz, MZCONFIG_LOAD_DELAY_ENABLED, scheme_false);
init_param(cells, paramz, MZCONFIG_DELAY_LOAD_INFO, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_GRAPH, scheme_false);
init_param(cells, paramz, MZCONFIG_PRINT_STRUCT, scheme_false);

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

@ -538,6 +538,8 @@ void scheme_register_traversers(void)
GC_REG_TRAV(scheme_thread_cell_values_type, small_object);
GC_REG_TRAV(scheme_global_ref_type, small_object);
GC_REG_TRAV(scheme_delay_syntax_type, small_object);
}
END_XFORM_SKIP;