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

scheme/package (and more int-def repairs)

Browse Source 
svn: r12589
This commit is contained in:
Matthew Flatt 2008-11-25 17:58:21 +00:00
parent ba54379202
commit ed536c002e
9 changed files with 210 additions and 105 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

11
collects/mzlib/unit.ss
View File

@ -126,8 +126,7 @@
((((int-sid . ext-sid) ...) . sbody) ...))
(map-sig (lambda (x) x)
(make-syntax-introducer)
sig)
#;(add-context-to-sig sig)])
sig)])
(list
#'((ext-ivar ... ext-vid ... ... ext-sid ... ...)
(values
@ -329,14 +328,6 @@
'expression
(list #'stop)
def-ctx))))
(define-for-syntax (add-context-to-sig sig)
(let ((def-ctx (syntax-local-make-definition-context)))
(syntax-local-bind-syntaxes (sig-ext-names sig) #f def-ctx)
(internal-definition-context-seal def-ctx)
(map-sig (lambda (x) x)
(lambda (x) (localify x def-ctx))
sig)))
(define-for-syntax (iota n)
(let loop ((n n)

162
collects/scheme/package.ss
View File

@ -4,13 +4,17 @@
syntax/boundmap
syntax/define))
(provide define*
(provide define-package
package-begin
open-package
open*-package
define*
define*-values
define*-syntax
define*-syntaxes
define-package
open-package
open*-package)
define*-struct)
(define-for-syntax (do-define-* stx define-values-id)
(syntax-case stx ()
@ -50,13 +54,15 @@
"misuse of a package name"
stx)))
(define (reverse-mapping id exports hidden)
(define (reverse-mapping who id exports hidden)
(or (ormap (lambda (m)
(and (free-identifier=? id (cdr m))
(car m)))
exports)
(ormap (lambda (h)
(and (free-identifier=? id h)
;; Not at top level, where free-id=? is unreliable:
(identifier-binding id)
;; Name is inaccessible. Generate a temporary to
;; avoid potential duplicate-definition errors
;; when the name is bound in the same context as
@ -65,19 +71,20 @@
hidden)
id)))
(define-syntax (define-package stx)
(syntax-case stx ()
[(_ pack-id exports form ...)
(define-for-syntax (do-define-package stx exp-stx)
(syntax-case exp-stx ()
[(_ pack-id mode exports form ...)
(let ([id #'pack-id]
[exports #'exports])
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier"
stx
id))
[exports #'exports]
[mode (syntax-e #'mode)])
(unless (eq? mode '#:begin)
(unless (identifier? id)
(raise-syntax-error #f
"expected an identifier"
stx
id)))
(let ([exports
(cond
[(eq? (syntax-e exports) 'all-defined) #f]
[(syntax->list exports)
=> (lambda (l)
(for-each (lambda (i)
@ -96,7 +103,11 @@
dup-id)))
l)]
[else (raise-syntax-error #f
"expected a parenthesized sequence of identifiers to export"
(format "expected a parenthesized sequence of identifiers ~a"
(case mode
[(#:only) "to export"]
[(#:all-defined-except) "to exclude from export"]
[else (format "for ~a" mode)]))
stx
exports)])])
(let* ([def-ctx (syntax-local-make-definition-context)]
@ -154,7 +165,18 @@
(quote-syntax renamed))
...))
hidden))))]
[_ stx])))])
[_ stx])))]
[complement (lambda (bindings ids)
(let ([tmp (make-bound-identifier-mapping)])
(bound-identifier-mapping-for-each bindings
(lambda (k v)
(bound-identifier-mapping-put! tmp k #t)))
(for-each (lambda (id)
(bound-identifier-mapping-put! tmp id #f))
ids)
(filter
values
(bound-identifier-mapping-map tmp (lambda (k v) (and v k))))))])
(let ([register-bindings!
(lambda (ids)
(for-each (lambda (id)
@ -186,7 +208,7 @@
(for-each (lambda (def-ctx)
(internal-definition-context-seal def-ctx))
def-ctxes)
(let ([exports-renamed (map (add-package-context def-ctxes) (or exports null))]
(let ([exports-renamed (map (add-package-context def-ctxes) exports)]
[defined-renamed (bound-identifier-mapping-map new-bindings
(lambda (k v) k))])
(for-each (lambda (ex renamed)
@ -194,33 +216,55 @@
renamed
(lambda () #f))
(raise-syntax-error #f
"no definition for exported identifier"
(format "no definition for ~a identifier"
(case mode
[(#:only) "exported"]
[(#:all-defined-except) "excluded"]))
stx
ex)))
(or exports null)
exports
exports-renamed)
(with-syntax ([(export ...) exports]
[(renamed ...) exports-renamed]
[(hidden ...)
(begin
(for-each (lambda (ex)
(bound-identifier-mapping-put! new-bindings ex #f))
exports-renamed)
(filter
values
(bound-identifier-mapping-map new-bindings
(lambda (k v) (and v k)))))])
#`(begin
#,@(map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
(reverse rev-forms))
(define-syntax pack-id
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
(lambda ()
(list (quote-syntax hidden) ...)))))))]
(let-values ([(exports exports-renamed)
(if (memq mode '(#:only #:begin))
(values exports exports-renamed)
(let ([all-exports-renamed (complement new-bindings exports-renamed)])
;; In case of define*, get only the last definition:
(let ([tmp (make-bound-identifier-mapping)])
(for-each (lambda (id)
(bound-identifier-mapping-put!
tmp
((add-package-context def-ctxes)
(pre-package-id id def-ctxes))
#t))
all-exports-renamed)
(let* ([exports-renamed (bound-identifier-mapping-map tmp (lambda (k v) k))]
[exports (map (lambda (id) (pre-package-id id def-ctxes))
exports-renamed)])
(values exports exports-renamed)))))])
(with-syntax ([(export ...) exports]
[(renamed ...) exports-renamed]
[(hidden ...) (complement new-bindings exports-renamed)])
(let ([body (map (fixup-sub-package exports-renamed defined-renamed def-ctxes)
(reverse rev-forms))])
(if (eq? mode '#:begin)
(if (eq? 'expression (syntax-local-context))
(quasisyntax/loc stx (let () #,@body))
(quasisyntax/loc stx (begin #,@body)))
(quasisyntax/loc stx
(begin
#,@(if (eq? 'top-level (syntax-local-context))
;; delcare all bindings before they are used:
#`((define-syntaxes #,defined-renamed (values)))
null)
#,@body
(define-syntax pack-id
(make-package
(lambda ()
(list (cons (quote-syntax export)
(quote-syntax renamed))
...))
(lambda ()
(list (quote-syntax hidden) ...)))))))))))]
[else
(let ([expr ((add-package-context (cdr def-ctxes))
(local-expand ((add-package-context (cdr def-ctxes)) (car exprs))
@ -276,11 +320,30 @@
(if star? (cons def-ctx def-ctxes) def-ctxes))))]
[else
(loop (cdr exprs)
(cons #`(define-values () (begin #,expr (values)))
(cons (if (and (eq? mode '#:begin)
(null? (cdr exprs)))
expr
#`(define-values () (begin #,expr (values))))
rev-forms)
defined
def-ctxes)]))]))))))]))
(define-syntax (define-package stx)
(syntax-case stx ()
[(_ id #:all-defined form ...)
(do-define-package stx #'(define-package id #:all-defined () form ...))]
[(_ id #:all-defined-except ids form ...)
(do-define-package stx stx)]
[(_ id #:only ids form ...)
(do-define-package stx stx)]
[(_ id ids form ...)
(do-define-package stx #'(define-package id #:only ids form ...))]))
(define-syntax (package-begin stx)
(syntax-case stx ()
[(_ form ...)
(do-define-package stx #'(define-package #f #:begin () form ...))]))
(define-for-syntax (do-open stx define-syntaxes-id)
(syntax-case stx ()
[(_ pack-id)
@ -316,6 +379,7 @@
(#,define-syntaxes-id (intro ...)
(let ([rev-map (lambda (x)
(reverse-mapping
'pack-id
x
(list (cons (quote-syntax a)
(quote-syntax b))
@ -328,3 +392,15 @@
(do-open stx #'define-syntaxes))
(define-syntax (open*-package stx)
(do-open stx #'define*-syntaxes))
(define-syntax (define*-struct stx)
(syntax-case stx ()
[(_ . rest)
(let ([ds (quasisyntax/loc stx
(define-struct/derived #,stx . rest))])
(quasisyntax/loc stx
(begin
(define-package p #:all-defined
#,ds)
(open*-package p))))]))

17
collects/scribblings/reference/syntax.scrbl
View File

@ -9,7 +9,8 @@
make-provide-transformer)
scheme/provide-syntax
scheme/provide
scheme/nest))
scheme/nest
scheme/package))
@(define cvt (schemefont "CVT"))
@ -68,10 +69,13 @@ Within such specifications,
@defform[(module id module-path form ...)]{
Declares a module. If the @scheme[current-module-declare-name]
parameter is set, the parameter value is used for the module name,
otherwise @scheme[(#,(scheme quote) id)] is the name of the declared
module.
Declares a top-level module. If the
@scheme[current-module-declare-name] parameter is set, the parameter
value is used for the module name, otherwise @scheme[(#,(scheme quote)
id)] is the name of the declared module.
@margin-note/ref{For a @scheme[module]-like form for use @emph{within}
modules and other contexts, see @scheme[define-package].}
The @scheme[module-path] must be as for @scheme[require], and it
supplies the initial bindings for the body @scheme[form]s. That is, it
@ -1931,6 +1935,9 @@ provides a hook to control interactive evaluation through
@scheme[load] (more precisely, the default @tech{load handler}) or
@scheme[read-eval-print-loop].}
@;------------------------------------------------------------------------
@include-section["package.scrbl"]
@;------------------------------------------------------------------------
@section[#:tag "nest"]{Flattening Syntactic Sequences: @scheme[nest]}

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

@ -154,6 +154,7 @@ typedef struct Compile_Data {
Scheme_Object **const_names;
Scheme_Object **const_vals;
Scheme_Object **const_uids;
int *sealed; /* NULL => already sealed */
int *use;
Scheme_Object *lifts;
} Compile_Data;
@ -1768,7 +1769,7 @@ Scheme_Object *scheme_tl_id_sym(Scheme_Env *env, Scheme_Object *id, Scheme_Objec
sym = SCHEME_STX_SYM(id);
if (_skipped)
*_skipped = 0;
*_skipped = -1;
if (SCHEME_HASHTP((Scheme_Object *)env)) {
marked_names = (Scheme_Hash_Table *)env;
@ -2131,6 +2132,12 @@ Scheme_Object *scheme_add_env_renames(Scheme_Object *stx, Scheme_Comp_Env *env,
return NULL;
}
if (SCHEME_RIBP(stx)) {
GC_CAN_IGNORE int *s;
s = scheme_stx_get_rib_sealed(stx);
COMPILE_DATA(env)->sealed = s;
}
while (env != upto) {
if (!(env->flags & (SCHEME_NO_RENAME | SCHEME_CAPTURE_WITHOUT_RENAME
| SCHEME_CAPTURE_LIFTED | SCHEME_INTDEF_SHADOW))) {
@ -2548,8 +2555,8 @@ scheme_lookup_binding(Scheme_Object *find_id, Scheme_Comp_Env *env, int flags,
val = COMPILE_DATA(frame)->const_vals[i];
if (!val) {
scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
"identifier used out of context");
scheme_wrong_syntax(scheme_compile_stx_string, NULL, find_id,
"identifier used out of context");
return NULL;
}
@ -4354,8 +4361,9 @@ local_get_shadower(int argc, Scheme_Object *argv[])
sym_marks = scheme_stx_extract_marks(sym);
/* Walk backward through the frames, looking for a renaming binding
with the same marks as the given identifier, sym. When we find
it, rename the given identifier so that it matches frame */
with the same marks as the given identifier, sym. Skip over
unsealed ribs, though. When we find a match, rename the given
identifier so that it matches frame. */
for (frame = env; frame->next != NULL; frame = frame->next) {
int i;
@ -4378,19 +4386,21 @@ local_get_shadower(int argc, Scheme_Object *argv[])
if (uid)
break;
for (i = COMPILE_DATA(frame)->num_const; i--; ) {
if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) {
if (SAME_OBJ(SCHEME_STX_VAL(sym),
SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) {
esym = COMPILE_DATA(frame)->const_names[i];
env_marks = scheme_stx_extract_marks(esym);
if (1 || scheme_equal(env_marks, sym_marks)) {
sym = esym;
if (COMPILE_DATA(frame)->const_uids) {
uid = COMPILE_DATA(frame)->const_uids[i];
} else
uid = frame->uid;
break;
if (!COMPILE_DATA(frame)->sealed || *COMPILE_DATA(frame)->sealed) {
for (i = COMPILE_DATA(frame)->num_const; i--; ) {
if (!(frame->flags & SCHEME_CAPTURE_WITHOUT_RENAME)) {
if (SAME_OBJ(SCHEME_STX_VAL(sym),
SCHEME_STX_VAL(COMPILE_DATA(frame)->const_names[i]))) {
esym = COMPILE_DATA(frame)->const_names[i];
env_marks = scheme_stx_extract_marks(esym);
if (scheme_equal(env_marks, sym_marks)) { /* This used to have 1 || --- why? */
sym = esym;
if (COMPILE_DATA(frame)->const_uids)
uid = COMPILE_DATA(frame)->const_uids[i];
else
uid = frame->uid;
break;
}
}
}
}
@ -4524,9 +4534,9 @@ local_make_delta_introduce(int argc, Scheme_Object *argv[])
}
if (!binder) {
/* Not a lexical biding, so use empty id */
binder = scheme_datum_to_syntax(scheme_intern_symbol("no-binder"),
scheme_false, scheme_false, 1, 0);
/* Not a lexical biding. Tell make-syntax-delta-introducer to
use module-binding information. */
binder = scheme_false;
}
a[0] = sym;

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

@ -5052,6 +5052,9 @@ Scheme_Object *scheme_check_immediate_macro(Scheme_Object *first,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
: 0)
+ ((rec[drec].comp && rec[drec].resolve_module_ids)
? SCHEME_RESOLVE_MODIDS
: 0),
@ -5253,7 +5256,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
: 0)
+ ((rec[drec].comp && rec[drec].resolve_module_ids)
? SCHEME_RESOLVE_MODIDS
: 0),
: 0)
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
: 0),
rec[drec].certs, env->in_modidx,
&menv, &protected, &lexical_binding_id);
@ -5357,7 +5363,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
+ SCHEME_DONT_MARK_USE
+ ((rec[drec].comp && rec[drec].resolve_module_ids)
? SCHEME_RESOLVE_MODIDS
: 0),
: 0)
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
: 0),
erec1.certs, env->in_modidx,
&menv, NULL, NULL);
@ -5440,7 +5449,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
var = scheme_lookup_binding(find_name, env,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE,
+ SCHEME_DONT_MARK_USE
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL, NULL);
@ -5480,7 +5492,10 @@ scheme_compile_expand_expr(Scheme_Object *form, Scheme_Comp_Env *env,
var = scheme_lookup_binding(stx, env,
SCHEME_NULL_FOR_UNBOUND
+ SCHEME_APP_POS + SCHEME_ENV_CONSTANTS_OK
+ SCHEME_DONT_MARK_USE,
+ SCHEME_DONT_MARK_USE
+ ((!rec[drec].comp && (rec[drec].depth == -2))
? SCHEME_OUT_OF_CONTEXT_OK
: 0),
rec[drec].certs, env->in_modidx,
&menv, NULL, NULL);
}
@ -9539,7 +9554,7 @@ local_eval(int argc, Scheme_Object **argv)
stx_env = (Scheme_Comp_Env *)SCHEME_PTR1_VAL(argv[2]);
rib = SCHEME_PTR2_VAL(argv[2]);
if (scheme_stx_is_rib_sealed(rib)) {
if (*scheme_stx_get_rib_sealed(rib)) {
scheme_raise_exn(MZEXN_FAIL_CONTRACT, "syntax-local-bind-syntaxes: given "
"internal-definition context has been sealed");
}

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

@ -2765,6 +2765,7 @@ static int mark_comp_env_MARK(void *p) {
gcMARK(e->data.const_names);
gcMARK(e->data.const_vals);
gcMARK(e->data.const_uids);
gcMARK(e->data.sealed);
gcMARK(e->data.use);
gcMARK(e->data.lifts);
@ -2792,6 +2793,7 @@ static int mark_comp_env_FIXUP(void *p) {
gcFIXUP(e->data.const_names);
gcFIXUP(e->data.const_vals);
gcFIXUP(e->data.const_uids);
gcFIXUP(e->data.sealed);
gcFIXUP(e->data.use);
gcFIXUP(e->data.lifts);

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

@ -1114,6 +1114,7 @@ mark_comp_env {
gcMARK(e->data.const_names);
gcMARK(e->data.const_vals);
gcMARK(e->data.const_uids);
gcMARK(e->data.sealed);
gcMARK(e->data.use);
gcMARK(e->data.lifts);

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

@ -722,7 +722,7 @@ void scheme_add_rib_rename(Scheme_Object *ro, Scheme_Object *rename);
void scheme_drop_first_rib_rename(Scheme_Object *ro);
Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro);
void scheme_stx_seal_rib(Scheme_Object *rib);
int scheme_stx_is_rib_sealed(Scheme_Object *rib);
int *scheme_stx_get_rib_sealed(Scheme_Object *rib);
Scheme_Object *scheme_add_rename(Scheme_Object *o, Scheme_Object *rename);
Scheme_Object *scheme_add_rename_rib(Scheme_Object *o, Scheme_Object *rib);

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

@ -1080,9 +1080,9 @@ void scheme_stx_seal_rib(Scheme_Object *rib)
*((Scheme_Lexical_Rib *)rib)->sealed = 1;
}
int scheme_stx_is_rib_sealed(Scheme_Object *rib)
int *scheme_stx_get_rib_sealed(Scheme_Object *rib)
{
return *((Scheme_Lexical_Rib *)rib)->sealed;
return ((Scheme_Lexical_Rib *)rib)->sealed;
}
Scheme_Object *scheme_stx_id_remove_rib(Scheme_Object *stx, Scheme_Object *ro)
@ -3453,7 +3453,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
Scheme_Object *phase = orig_phase;
Scheme_Object *bdg = NULL, *floating = NULL;
Scheme_Hash_Table *export_registry = NULL;
int mresult_skipped = 0;
int mresult_skipped = -1;
int depends_on_unsealed_rib = 0;
EXPLAIN(fprintf(stderr, "%d Resolving %s [skips: %s]:\n", depth, SCHEME_SYM_VAL(SCHEME_STX_VAL(a)),
@ -3578,7 +3578,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
o_rename_stack = scheme_null;
}
} else {
skipped = 0;
skipped = -1;
glob_id = SCHEME_STX_VAL(a);
}
@ -3695,7 +3695,7 @@ static Scheme_Object *resolve_env(WRAP_POS *_wraps,
}
} else {
mresult = scheme_false;
mresult_skipped = 0;
mresult_skipped = -1;
if (get_names)
get_names[0] = NULL;
}
@ -3993,7 +3993,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
if (!rename)
result = scheme_search_shared_pes(mrn->shared_pes, glob_id, a, NULL, 1);
else if (rename) {
else {
/* match; set result: */
if (mrn->kind == mzMOD_RENAME_MARKED)
skip_other_mods = 1;
@ -4007,8 +4007,7 @@ static Scheme_Object *get_module_src_name(Scheme_Object *a, Scheme_Object *orig_
}
} else
result = glob_id;
} else
result = NULL;
}
result_from = WRAP_POS_FIRST(wraps);
}
@ -7258,33 +7257,37 @@ Scheme_Object *scheme_syntax_make_transfer_intro(int argc, Scheme_Object **argv)
if (!SCHEME_STXP(argv[0]) || !SCHEME_SYMBOLP(SCHEME_STX_VAL(argv[0])))
scheme_wrong_type("make-syntax-delta-introducer", "syntax identifier", 0, argc, argv);
if (!SCHEME_STXP(argv[1]))
scheme_wrong_type("make-syntax-delta-introducer", "syntax", 1, argc, argv);
if (!SCHEME_STXP(argv[1]) && !SCHEME_FALSEP(argv[1]))
scheme_wrong_type("make-syntax-delta-introducer", "syntax or #f", 1, argc, argv);
phase = extract_phase("make-syntax-delta-introducer", 2, argc, argv, scheme_make_integer(0), 1);
m1 = scheme_stx_extract_marks(argv[0]);
orig_m1 = m1;
m2 = scheme_stx_extract_marks(argv[1]);
l1 = scheme_list_length(m1);
l2 = scheme_list_length(m2);
delta = scheme_null;
while (l1 > l2) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
if (SCHEME_FALSEP(argv[1])) {
m2 = scheme_false;
} else {
m2 = scheme_stx_extract_marks(argv[1]);
l2 = scheme_list_length(m2);
while (l1 > l2) {
delta = CONS(SCHEME_CAR(m1), delta);
m1 = SCHEME_CDR(m1);
l1--;
}
}
if (!scheme_equal(m1, m2)) {
/* tails don't match, so keep all marks --- except
those that determine a module binding */
int skipped = 0;
int skipped = -1;
resolve_env(NULL, argv[0], phase, 1, NULL, NULL, &skipped, NULL, 0);
if (skipped) {
if (skipped > -1) {
/* Just keep the first `skipped' marks. */
delta = scheme_null;
m1 = orig_m1;