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

fix 'local-expand' checking of stop list to disallow symbols; extend 'continuation-marks' to work on threads; fix HtDP language module-level stop list

Browse Source 
svn: r12101
This commit is contained in:
Matthew Flatt 2008-10-23 13:38:03 +00:00
parent 4db61ef355
commit bb7d3d1a28
16 changed files with 109 additions and 25 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

14
collects/lang/private/contracts/contracts-module-begin.ss
View File

@ -3,7 +3,8 @@
(require "contracts.ss")
(require-for-syntax mzlib/list
syntax/boundmap)
syntax/boundmap
syntax/kerncase)
(provide beginner-module-begin intermediate-module-begin advanced-module-begin)
@ -144,9 +145,9 @@
[_ (raise-syntax-error 'contract "internal error.5")])))
(define local-expand-stop-list
(list 'contract 'define-values 'define-syntaxes 'define-values-for-syntax '#%require
'#%provide 'define-data '#%app '#%datum 'define-struct 'begin 'begin0))
(append (list #'contract #'#%require #'#%provide language-level-define-data)
(kernel-form-identifier-list)))
;; parse-contract-expressions
;; takes in a list of top level expressions and a list of contracts, and outputs the correct transformation.
;; 1. expand until we find a definition or a contract
@ -165,7 +166,7 @@
[else
(let ([expanded (car exprs)])
(syntax-case expanded (begin define-values define-data)
(syntax-case expanded (begin define-values)
[(define-values (func) e1 ...)
(contract-defined? cnt-list expanded)
(let ([cnt (get-contract cnt-list expanded)])
@ -175,7 +176,8 @@
#,(transform-contract ll-contract cnt expanded)
#,(loop (remove cnt cnt-list) (cdr exprs)))))]
[(define-data name c1 c2 ...)
(identifier? #'name)
(and (identifier? #'name)
(define-data-stx? expanded))
(quasisyntax/loc (car exprs)
(begin
(#,ll-define-data name c1 c2 ...)

4
collects/mzlib/private/sigutil.ss
View File

@ -645,7 +645,9 @@
swapped-renames)
(loop (cdr e))
(cons (car e) (loop (cdr e)))))))]
[local-vars (append renamed-internals filtered-exported-names imported-names)]
[local-vars (map (lambda (s)
(datum->syntax-object expr s))
(append renamed-internals filtered-exported-names imported-names))]
[expand-context (generate-expand-context)]
[import-stxes (apply append (map (lambda (i)
(map

5
collects/scribblings/guide/define-struct.scrbl
View File

@ -393,8 +393,9 @@ A @scheme[_struct-option] always starts with a keyword:
Specifies a value to be used for all automatic fields in the
structure type, where an automatic field is indicated by the
@scheme[#:auto] field option. The constructor procedure does not
accept arguments for automatic fields, and they are implicitly
mutable.
accept arguments for automatic fields. Automatic fields are
implicitly mutable (via reflective operations), but mutator
functions are bound only if @scheme[#:mutator] is also specified.
@defexamples[
(define-struct posn (x y [z #:auto])

19
collects/scribblings/reference/cont-marks.scrbl
View File

@ -46,18 +46,21 @@ continuation's frames to the marks that were present when
@scheme[call-with-current-continuation] or
@scheme[call-with-composable-continuation] was invoked.
@defproc[(continuation-marks [cont continuation?]
@defproc[(continuation-marks [cont (or/c continuation? thread?)]
[prompt-tag prompt-tag? (default-continuation-prompt-tag)])
continuation-mark-set?]{
Returns an opaque value containing the set of continuation marks for
all keys in the continuation @scheme[cont] up to the prompt tagged by
@scheme[prompt-tag]. If @scheme[cont] is an escape continuation (see
@secref["prompt-model"]), then the current continuation must extend
@scheme[cont], or the @exnraise[exn:fail:contract]. If @scheme[cont]
was not captured with respect to @scheme[prompt-tag] and does not
include a prompt for @scheme[prompt-tag], the
@exnraise[exn:fail:contract].}
all keys in the continuation @scheme[cont] (or the current
continuation of @scheme[cont] if it is a thread) up to the prompt
tagged by @scheme[prompt-tag]. If @scheme[cont] is an escape
continuation (see @secref["prompt-model"]), then the current
continuation must extend @scheme[cont], or the
@exnraise[exn:fail:contract]. If @scheme[cont] was not captured with
respect to @scheme[prompt-tag] and does not include a prompt for
@scheme[prompt-tag], the @exnraise[exn:fail:contract]. If
@scheme[cont] is a dead thread, the result is an empty set of
continuation marks.}
@defproc[(current-continuation-marks [prompt-tag prompt-tag? (default-continuation-prompt-tag)])
continuation-mark-set?]{

4
collects/scribblings/reference/define-struct.scrbl
View File

@ -127,7 +127,9 @@ If @scheme[#:auto] is supplied as a @scheme[field-option], then the
argument corresponding to the field. Instead, the structure type's
automatic value is used for the field, as specified by the
@scheme[#:auto-value] option, or as defaults to @scheme[#f] when
@scheme[#:auto-value] is not supplied.
@scheme[#:auto-value] is not supplied. The field is mutable (e.g.,
through reflective operations), but a mutator procedure is bound only
if @scheme[#:mutable] is specified.
If a @scheme[field] includes the @scheme[#:auto] option, then all
fields after it must also include @scheme[#:auto], otherwise a syntax

2
collects/swindle/setf.ss
View File

@ -44,7 +44,7 @@
;; need to expand place first, in case it is itself a macro
(with-syntax ([place (local-expand
#'place 'expression
(append '(#%app #%top #%datum)
(append (list #'#%app #'#%top #'#%datum)
(map (lambda (s)
(datum->syntax-object #'place s #f))
'(#%app #%top #%datum))))])

1
collects/syntax/kerncase.ss
View File

@ -75,6 +75,7 @@
(define (kernel-form-identifier-list)
(syntax-e (quote-syntax
(begin
begin0
define-values
define-syntaxes
define-values-for-syntax

6
collects/syntax/scribblings/kerncase.scrbl
View File

@ -44,5 +44,7 @@ primitive PLT Scheme forms.}
Returns a list of identifiers that are bound normally,
@scheme[for-syntax], and @scheme[for-template] to the primitive PLT
Scheme forms for expressions. This function is useful for generating a
list of stopping points to provide to @scheme[local-expand].}
Scheme forms for expressions and internal-definition positions (so the
list does not include @scheme[#%require] or @scheme[#%provide]). This
function is useful for generating a list of stopping points to provide
to @scheme[local-expand].}

6
doc/release-notes/mzscheme/HISTORY.txt
View File

@ -1,3 +1,9 @@
Version 4.1.1.3
Changed binding of identifiers introduced by unit signatures
to take into account the signature use's context
Added make-syntax-delta-introducer
Changed continuation-marks to accept a thread argument
Version 4.1.1.2
Added eqv-based hash tables
Added hash-update and hash-update!

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

@ -1007,6 +1007,9 @@ typedef struct Scheme_Thread {
char ran_some;
char suspend_to_kill;
struct Scheme_Thread *return_marks_to;
Scheme_Object *returned_marks;
struct Scheme_Overflow *overflow;
struct Scheme_Comp_Env *current_local_env;

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

@ -9053,7 +9053,7 @@ do_local_expand(const char *name, int for_stx, int catch_lifts, int for_expr, in
Scheme_Object *i;
i = SCHEME_CAR(l);
if (!SCHEME_STX_SYMBOLP(i)) {
if (!SCHEME_STXP(i) || !SCHEME_STX_SYMBOLP(i)) {
scheme_wrong_type(name, "#f or list of identifier syntax", 2, argc, argv);
return NULL;
}

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

@ -6785,8 +6785,8 @@ cont_marks(int argc, Scheme_Object *argv[])
{
Scheme_Object *prompt_tag;
if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]))
scheme_wrong_type("continuation-marks", "continuation", 0, argc, argv);
if (!SCHEME_CONTP(argv[0]) && !SCHEME_ECONTP(argv[0]) && !SCHEME_THREADP(argv[0]))
scheme_wrong_type("continuation-marks", "continuation or thread", 0, argc, argv);
if (argc > 1) {
if (!SAME_TYPE(scheme_prompt_tag_type, SCHEME_TYPE(argv[1]))) {
@ -6810,6 +6810,38 @@ cont_marks(int argc, Scheme_Object *argv[])
return continuation_marks(scheme_current_thread, NULL, argv[0], mc, prompt_tag,
"continuation-marks", 0);
}
} else if (SCHEME_THREADP(argv[0])) {
Scheme_Thread *t = (Scheme_Thread *)argv[0];
Scheme_Object *m;
if (SAME_OBJ(t, scheme_current_thread))
return scheme_current_continuation_marks(prompt_tag);
while (t->return_marks_to) {
scheme_thread_block(0.0);
}
if (!(t->running & MZTHREAD_RUNNING)) {
/* empty marks */
Scheme_Cont_Mark_Set *set;
set = MALLOC_ONE_TAGGED(Scheme_Cont_Mark_Set);
set->so.type = scheme_cont_mark_set_type;
set->chain = NULL;
set->cmpos = 1;
set->native_stack_trace = NULL;
return (Scheme_Object *)set;
} else {
t->return_marks_to = scheme_current_thread;
t->returned_marks = prompt_tag;
scheme_swap_thread(t);
m = t->returned_marks;
t->returned_marks = NULL;
return m;
}
} else {
return continuation_marks(NULL, argv[0], NULL, NULL, prompt_tag,
"continuation-marks", 0);

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

@ -2918,7 +2918,7 @@ static Scheme_Object *_module_resolve(Scheme_Object *modidx, Scheme_Object *stx,
scheme_push_continuation_frame(&cframe);
scheme_set_cont_mark(scheme_parameterization_key, (Scheme_Object *)config);
}
name = scheme_apply(scheme_get_param(scheme_current_config(), MZCONFIG_CURRENT_MODULE_RESOLVER), 4, a);
if (env) {

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

@ -1626,6 +1626,9 @@ static int thread_val_MARK(void *p) {
gcMARK(pr->blocker);
gcMARK(pr->overflow);
gcMARK(pr->return_marks_to);
gcMARK(pr->returned_marks);
gcMARK(pr->current_local_env);
gcMARK(pr->current_local_mark);
@ -1729,6 +1732,9 @@ static int thread_val_FIXUP(void *p) {
gcFIXUP(pr->blocker);
gcFIXUP(pr->overflow);
gcFIXUP(pr->return_marks_to);
gcFIXUP(pr->returned_marks);
gcFIXUP(pr->current_local_env);
gcFIXUP(pr->current_local_mark);

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

@ -641,6 +641,9 @@ thread_val {
gcMARK(pr->blocker);
gcMARK(pr->overflow);
gcMARK(pr->return_marks_to);
gcMARK(pr->returned_marks);
gcMARK(pr->current_local_env);
gcMARK(pr->current_local_mark);

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

@ -2413,8 +2413,19 @@ int scheme_in_main_thread(void)
return !scheme_current_thread->next;
}
static void stash_current_marks()
{
Scheme_Object *m;
m = scheme_current_continuation_marks(scheme_current_thread->returned_marks);
scheme_current_thread->returned_marks = m;
swap_target = scheme_current_thread->return_marks_to;
scheme_current_thread->return_marks_to = NULL;
}
static void do_swap_thread()
{
start:
scheme_zero_unneeded_rands(scheme_current_thread);
#if WATCH_FOR_NESTED_SWAPS
@ -2454,6 +2465,11 @@ static void do_swap_thread()
&& ((*scheme_current_thread->cont_mark_stack_owner) != scheme_current_thread))) {
scheme_takeover_stacks(scheme_current_thread);
}
if (scheme_current_thread->return_marks_to) {
stash_current_marks();
goto start;
}
} else {
Scheme_Thread *new_thread = swap_target;
@ -2769,6 +2785,11 @@ static void start_child(Scheme_Thread * volatile child,
exit_or_escape(scheme_current_thread);
}
if (scheme_current_thread->return_marks_to) {
stash_current_marks();
do_swap_thread();
}
{
mz_jmp_buf newbuf;
scheme_current_thread->error_buf = &newbuf;