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

fix struct-out; add -I configuration option

Browse Source 
svn: r8530
This commit is contained in:
Matthew Flatt 2008-02-04 21:51:39 +00:00
parent 59b5f3a727
commit 096ec546a6
8 changed files with 214 additions and 126 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

3
collects/mzscheme/info.ss
View File

@ -1,4 +1,5 @@
(module info setup/infotab
(define name "MzScheme")
(define version '(400)))
(define version '(400))
(define scribblings '(("mzscheme.scrbl" (multi-page)))))

49
collects/scheme/private/reqprov.ss
View File

@ -779,8 +779,8 @@
(raise-syntax-error
#f
"expected an identifier for a struct-type name, but found something else"
id
stx))
stx
id))
(let ([v (syntax-local-value id (lambda () #f))])
(if (struct-info? v)
(let* ([v (extract-struct-info v)]
@ -799,16 +799,49 @@
(car super-ids)))
;; stop because we got to ids that belong to the supertype
null]
[else (cons (car ids) (loop (cdr ids)))])))])
[else (cons (car ids) (loop (cdr ids)))])))]
;; FIXME: we're building a list of all imports on every expansion
;; of `syntax-out'. That could become expensive if `syntax-out' is
;; used a lot.
[avail-ids (append (let-values ([(ids _) (syntax-local-module-defined-identifiers)])
ids)
(let-values ([(ids _ __)
(syntax-local-module-required-identifiers #f #t #f #f)])
ids))]
[find-imported/defined (lambda (id)
(let ([ids (filter (lambda (id2)
(and (free-identifier=? id2 id)
id2))
avail-ids)])
(cond
[(or (null? ids)
(pair? (cdr ids)))
(raise-syntax-error
#f
(if (null? ids)
"no import for structure-type identifier"
(format "multiple imports (~a~a~a~a) for structure-type identifier"
(syntax-e (car ids))
(if (null? (cddr ids))
" and "
", ")
(syntax-e (cadr ids))
(if (null? (cddr ids))
""
", ...")))
stx
id)]
[else (car ids)])))])
(filter
values
(map (lambda (id)
(and id
(make-export id
(syntax-e id)
'run
#f
id)))
(let ([id (find-imported/defined id)])
(make-export id
(syntax-e id)
'run
#f
id))))
(append
(list id
(list-ref v 0)

15
collects/scribblings/reference/startup.scrbl
View File

@ -57,7 +57,9 @@ command line does not specify a @scheme[require] flag
@Flag{u}/@DFlag{require-script}) before any @scheme[eval],
@scheme[load], or read-eval-print-loop flag (@Flag{e}/@DFlag{eval},
@Flag{f}/@DFlag{load}, @Flag{r}/@DFlag{script}, @Flag{m}/@DFlag{main},
@Flag{i}/@DFlag{repl}, or @Flag{z}/@DFlag{text-repl}).
@Flag{i}/@DFlag{repl}, or @Flag{z}/@DFlag{text-repl}). The
initialization library can be changed with the @Flag{I}
@tech{configuration option}.
After potentially loading the initialization module, expression
@scheme[eval]s, files @scheme[load]s, and module @scheme[require]s are
@ -171,9 +173,10 @@ flags:
@scheme[(find-system-path 'init-file)] for
@Flag{i}/@DFlag{repl} or @Flag{z}/@DFlag{text-repl}.}
@item{@FlagFirst{n} or @DFlagFirst{no-lib} : Skips requiring
@schememodname[scheme/init] or @schememodname[scheme/gui/init]
when not otherwise disabled.}
@item{@FlagFirst{n} or @DFlagFirst{no-lib} : Skips requiring the
initialization library (i.e., @schememodname[scheme/init] or
@schememodname[scheme/gui/init], unless it is changed with the
@Flag{I} flag) when not otherwise disabled.}
@item{@FlagFirst{v} or @DFlagFirst{version} : Shows
@scheme[(banner)].}
@ -196,6 +199,10 @@ flags:
of compiled byte-code @filepath{.zo} files, by initializing
@scheme[current-compiled-file-paths] to @scheme[null].}
@item{@FlagFirst{I} @nonterm{path} : Sets @scheme[(lib #,
@nontermstr{path})] as the path to @scheme[require] to initialize
the namespace, unless namespace initialization is disabled.}
@item{@FlagFirst{X} @nonterm{dir} or @DFlagFirst{collects}
@nonterm{dir} : Sets @nonterm{dir} as the path to the main
collection of libraries by making @scheme[(find-system-path

5
collects/scribblings/reference/stx-trans.scrbl
View File

@ -474,7 +474,7 @@ for-syntax) definitions.}
@defproc[(syntax-local-module-required-identifiers
[mod-path module-path?]
[mod-path (or/c module-path? false/c)]
[normal-imports? any/c]
[syntax-imports? any/c]
[label-imports? any/c])
@ -488,7 +488,8 @@ Can be called only while
It returns three lists of identifiers corresponding to all bindings
imported into the module being expanded using the module path
@scheme[mod-path]. This information is used for implementing
@scheme[mod-path], or all modules if @scheme[mod-path] is
@scheme[#f]. This information is used for implementing
@scheme[provide] sub-forms like @scheme[all-from-out].
The first result list corresponds to @tech{phase level} 0 (i.e.,

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

@ -226,9 +226,11 @@ expander introduces @schemeidfont{#%app} identifiers.
(#%app cons)
]}
@defform[(#%plain-app proc-expr arg-expr ...)]{
@defform*[[(#%plain-app proc-expr arg-expr ...)
(#%plain-app)]]{
Like @scheme[#%app], but without support for keyword arguments.
}
As a special case, @scheme[(#%plain-app)] produces @scheme['()].}
@;------------------------------------------------------------------------
@section[#:tag "lambda"]{Procedure Expressions: @scheme[lambda] and @scheme[case-lambda]}
@ -1452,9 +1454,11 @@ The syntax of @scheme[provide-spec] can be extended via
pre-defined forms are as follows.
@specsubform[id]{ Exports @scheme[id], which must be @tech{bound}
within the module (i.e., either defined or imported) at the relevant @tech{phase
level} 0. The symbolic form of @scheme[id] is used as the external
name.}
within the module (i.e., either defined or imported) at the relevant
@tech{phase level}. The symbolic form of @scheme[id] is used as the
external name, and the symbolic form of the defined or imported
identifier must match (otherwise, the external name could be
ambiguous). }
@defsubform[(all-defined-out)]{ Exports all identifiers that are
defined at @tech{phase level} 0 or @tech{phase level} 1 within the
@ -1491,17 +1495,19 @@ pre-defined forms are as follows.
Like @scheme[provide-spec], but with each symbolic export name from
@scheme[provide-spec] prefixed with @scheme[prefix-id].}
@defsubform[(struct-out id)]{Exports the bindings associated
with a structure type @scheme[id]. Typically, @scheme[id] is
bound with @scheme[(define-struct id ....)] or
@scheme[(define-struct (id super-id) ....)]; more generally,
@scheme[id] must have a @tech{transformer binding} of structure-type
information at @tech{phase level} 0; see @secref["structinfo"].
If the structure-type information includes a super-type
identifier, and if the identifier has a @tech{transformer
binding} of structure-type information, the accessor and mutator
bindings of the super-type are @italic{not} included by
@scheme[struct-out] for export.}
@defsubform[(struct-out id)]{Exports the bindings associated with a
structure type @scheme[id]. Typically, @scheme[id] is bound with
@scheme[(define-struct id ....)] or @scheme[(define-struct (id
super-id) ....)]; more generally, @scheme[id] must have a
@tech{transformer binding} of structure-type information at
@tech{phase level} 0; see @secref["structinfo"]. Furthermore, for
each identifier mentioned in the structure-type information, the
enclosing module must define or import one identifier that is
@scheme[free-identifier=?]. If the structure-type information
includes a super-type identifier, and if the identifier has a
@tech{transformer binding} of structure-type information, the
accessor and mutator bindings of the super-type are @italic{not}
included by @scheme[struct-out] for export.}
@defsubform[(protect-out provide-spec ...)]{ Like the union of the
@scheme[provide-spec]s, except that the exports are protected; see

26
src/mzscheme/cmdline.inc
View File

@ -208,6 +208,7 @@ typedef struct {
Scheme_Object *main_args;
#endif
Scheme_Env *global_env;
char *init_lib;
} FinishArgs;
typedef void (*Repl_Proc)(Scheme_Env *);
@ -222,7 +223,9 @@ static int finish_cmd_line_run(FinishArgs *fa, Repl_Proc repl)
mz_jmp_buf * volatile save, newbuf;
nsreq = scheme_builtin_value("namespace-require");
a[0] = scheme_intern_symbol(INITIAL_NAMESPACE_MODULE);
a[0] = scheme_make_pair(scheme_intern_symbol("lib"),
scheme_make_pair(scheme_make_utf8_string(fa->init_lib),
scheme_make_null()));
p = scheme_get_current_thread();
save = p->error_buf;
@ -489,6 +492,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
int alternate_rep = 0;
int no_front = 0;
#endif
char *init_lib = INITIAL_NAMESPACE_MODULE;
int was_config_flag = 0, saw_nc_flag = 0;
int no_compiled = 0;
int init_ns = 0, no_init_ns = 0;
@ -749,6 +753,17 @@ static int run_from_cmd_line(int argc, char *_argv[],
scheme_set_ignore_user_paths(1);
was_config_flag = 1;
break;
case 'I':
if (argc < 2) {
PRINTF("%s: missing path after %s switch\n",
prog, real_switch);
goto show_need_help;
}
argv++;
--argc;
init_lib = argv[0];
was_config_flag = 1;
break;
case 'S':
if (argc < 2) {
PRINTF("%s: missing path after %s switch\n",
@ -941,7 +956,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
/* No args => repl */
use_repl = 1;
init_ns = 1;
} else if ((argv[0][0] != '-') && !is_number_arg(argv[0] + 1)) {
} else if (argv[0][0] != '-') {
/* No switches => -u mode */
script_mode = 1;
no_more_switches = 1;
@ -1070,6 +1085,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
fa->a->alternate_rep = alternate_rep;
fa->a->no_front = no_front;
#endif
fa->init_lib = init_lib;
fa->global_env = global_env;
scheme_set_can_break(1);
@ -1111,7 +1127,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
" -z, --text-repl : Like -i, but use text read-eval-print loop\n"
# endif
" -q, --no-init-file : Skip load of " INIT_FILENAME " for " REPL_FLAGS "\n"
" -n, --no-lib : Skip `(require (lib \"" INITIAL_NAMESPACE_MODULE "\"))' for " REPL_FLAGS "/-e/-f/-r\n"
" -n, --no-lib : Skip `(require (lib \"<init-lib>\"))' for " REPL_FLAGS "/-e/-f/-r\n"
" -v, --version : Show version\n"
# ifdef CMDLINE_STDIO_FLAG
" -K, --back : Don't bring application to the foreground (Mac OS X)\n"
@ -1121,6 +1137,7 @@ static int run_from_cmd_line(int argc, char *_argv[],
# endif
" Configuration options:\n"
" -c, --no-compiled : Disable loading of compiled files\n"
" -I <path> : Set <init-lib> to <path>\n"
" -X <dir>, --collects <dir> : Main collects at <dir> relative to " PROGRAM "\n"
" -S <dir>, --search <dir> : More collects at <dir> relative to " PROGRAM "\n"
" -U, --no-user-path : Ignore user-specific collects, etc.\n"
@ -1139,13 +1156,14 @@ static int run_from_cmd_line(int argc, char *_argv[],
" If only configuration options are provided, -i is added\n"
" If only configuration options are before the first argument, -u is added\n"
" If -t/-l/-p/-u apears before the first -i/-e/-f/-r, -n is added\n"
" <init-lib> defaults to " INITIAL_NAMESPACE_MODULE "\n"
"Switch syntax:\n"
" Multiple single-letter switches can be collapsed, with arguments placed\n"
" after the collapsed switches; the first collapsed switch cannot be --\n"
" Example: `-ifve file expr' is the same as `-i -f file -v -e expr'\n"
"Start-up sequence:\n"
" 1. Set `current-library-collection-paths'\n"
" 2. Require `(lib \"" INITIAL_NAMESPACE_MODULE "\")' [when " REPL_FLAGS "/-e/-f/-r, unless -n]\n"
" 2. Require `(lib \"<init-lib>\")' [when " REPL_FLAGS "/-e/-f/-r, unless -n]\n"
" 3. Evaluate/load expressions/files in order, until first error\n"
" 4. Load \"" INIT_FILENAME "\" [when " REPL_FLAGS "]\n"
" 5. Run read-eval-print loop [when " REPL_FLAGS "]\n"

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

@ -4302,8 +4302,8 @@ local_module_imports(int argc, Scheme_Object *argv[])
scheme_raise_exn(MZEXN_FAIL_CONTRACT,
"syntax-local-module-required-identifiers: not currently transforming module provides");
if (!scheme_is_module_path(argv[0]))
scheme_wrong_type("syntax-local-module-required-identifiers", "module-path", 0, argc, argv);
if (SCHEME_TRUEP(argv[0]) && !scheme_is_module_path(argv[0]))
scheme_wrong_type("syntax-local-module-required-identifiers", "module-path or #f", 0, argc, argv);
return scheme_module_imported_list(scheme_current_thread->current_local_env->genv,
scheme_current_thread->current_local_bindings,

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

@ -6109,8 +6109,8 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
{
Scheme_Hash_Table *provided, *required;
int i, k;
Scheme_Object *rx;
int reprovide_kernel = 0;
Scheme_Object *rx, *provided_list;
int reprovide_kernel = 0, all_mods = 0;
int src_phase_index;
if (phase == MZ_LABEL_PHASE)
@ -6118,76 +6118,84 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
else
src_phase_index = phase;
if (SCHEME_FALSEP(reprovided)) {
all_mods = 1;
/* more convenient: */
reprovided = scheme_make_pair(scheme_false, scheme_null);
}
/* First, check the sanity of the re-provide specifications: */
for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns;
if (!all_mods) {
for (rx = reprovided; !SCHEME_NULLP(rx); rx = SCHEME_CDR(rx)) {
Scheme_Object *midx = SCHEME_CAR(SCHEME_CAR(rx)), *l, *exns;
for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (same_modidx(midx, SCHEME_CAR(l)))
break;
}
if (SCHEME_NULLP(l)) {
/* Didn't require the named module */
if (matching_form) {
Scheme_Object *name;
name = SCHEME_CAR(rx);
name = SCHEME_STX_CDR(name);
name = SCHEME_STX_CAR(name);
scheme_wrong_syntax("module",
SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path,
name,
"cannot provide from a module without a matching `%s'",
matching_form);
} else {
return -1;
for (l = requires; SCHEME_PAIRP(l); l = SCHEME_CDR(l)) {
if (same_modidx(midx, SCHEME_CAR(l)))
break;
}
}
exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx)));
for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) {
/* Make sure excluded name was required: */
Scheme_Object *a, *vec;
a = SCHEME_STX_VAL(SCHEME_STX_CAR(l));
for (k = 0; k < 3; k++) {
switch (k) {
case 0:
required = _required;
break;
case 1:
required = _et_required;
break;
default:
case 2:
required = _dt_required;
break;
if (SCHEME_NULLP(l)) {
/* Didn't require the named module */
if (matching_form) {
Scheme_Object *name;
name = SCHEME_CAR(rx);
name = SCHEME_STX_CDR(name);
name = SCHEME_STX_CAR(name);
scheme_wrong_syntax("module",
SCHEME_MODNAMEP(midx) ? midx : ((Scheme_Modidx *)midx)->path,
name,
"cannot provide from a module without a matching `%s'",
matching_form);
} else {
return -1;
}
if (required)
vec = scheme_hash_get(required, a);
else
vec = NULL;
if (vec) {
/* Check for nominal modidx in list */
Scheme_Object *nml, *nml_modidx;
nml = SCHEME_VEC_ELS(vec)[0];
for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
nml_modidx = SCHEME_CAR(nml);
if (SCHEME_PAIRP(nml_modidx))
nml_modidx = SCHEME_CAR(nml_modidx);
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx))
break;
}
exns = SCHEME_CDR(SCHEME_CDR(SCHEME_CAR(rx)));
for (l = exns; !SCHEME_STX_NULLP(l); l = SCHEME_STX_CDR(l)) {
/* Make sure excluded name was required: */
Scheme_Object *a, *vec;
a = SCHEME_STX_VAL(SCHEME_STX_CAR(l));
for (k = 0; k < 3; k++) {
switch (k) {
case 0:
required = _required;
break;
case 1:
required = _et_required;
break;
default:
case 2:
required = _dt_required;
break;
}
if (required)
vec = scheme_hash_get(required, a);
else
vec = NULL;
if (vec) {
/* Check for nominal modidx in list */
Scheme_Object *nml, *nml_modidx;
nml = SCHEME_VEC_ELS(vec)[0];
for (; SCHEME_PAIRP(nml); nml = SCHEME_CDR(nml)) {
nml_modidx = SCHEME_CAR(nml);
if (SCHEME_PAIRP(nml_modidx))
nml_modidx = SCHEME_CAR(nml_modidx);
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nml_modidx))
break;
}
if (!SCHEME_PAIRP(nml))
vec = NULL; /* So it was provided, but not from the indicated module */
}
if (!SCHEME_PAIRP(nml))
vec = NULL; /* So it was provided, but not from the indicated module */
}
if (vec)
break;
}
if (!vec) {
a = SCHEME_STX_CAR(l);
scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)),
"excluded name was not required from the module");
if (vec)
break;
}
if (!vec) {
a = SCHEME_STX_CAR(l);
scheme_wrong_syntax("module", a, SCHEME_CADR(SCHEME_CAR(rx)),
"excluded name was not required from the module");
}
}
}
}
@ -6210,6 +6218,8 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
break;
}
provided_list = scheme_null;
if (required) {
for (i = required->size; i--; ) {
if (required->vals[i]) {
@ -6228,7 +6238,7 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
nominal_modidx = SCHEME_CAR(nml);
if (SCHEME_PAIRP(nominal_modidx))
nominal_modidx = SCHEME_CAR(nominal_modidx);
if (same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) {
if (all_mods || same_modidx(SCHEME_CAR(SCHEME_CAR(rx)), nominal_modidx)) {
Scheme_Object *pi, *nml_pi;
if (SCHEME_PAIRP(SCHEME_CAR(nml))) {
@ -6241,16 +6251,21 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
Scheme_Object *exns, *ree;
break_outer = 1;
ree = SCHEME_CDR(SCHEME_CAR(rx));
if (!all_mods) {
break_outer = 1;
ree = SCHEME_CDR(SCHEME_CAR(rx));
exns = SCHEME_CDR(ree);
if (SAME_OBJ(modidx, kernel_modidx))
if (!SCHEME_STX_NULLP(exns)) {
if (_exclude_hint)
*_exclude_hint = exns;
}
exns = SCHEME_CDR(ree);
if (SAME_OBJ(modidx, kernel_modidx))
if (!SCHEME_STX_NULLP(exns)) {
if (_exclude_hint)
*_exclude_hint = exns;
}
} else {
ree = NULL;
exns = scheme_null;
}
for (; !SCHEME_STX_NULLP(exns); exns = SCHEME_STX_CDR(exns)) {
/* Was this name excluded? */
@ -6263,6 +6278,7 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
if (SCHEME_STX_NULLP(exns)) {
/* Not excluded, so provide it. */
if (matching_form) {
/* Assert: !all_mods */
check_already_provided(provided, outname, name, 0, SCHEME_CAR(ree), phase);
scheme_hash_set(provided, outname, scheme_make_pair(name, scheme_false));
} else {
@ -6284,7 +6300,8 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
} else {
scheme_signal_error("found an import with no lexical context");
}
scheme_hash_set(provided, outname, name);
provided_list = scheme_make_pair(name, provided_list);
}
if (SAME_OBJ(modidx, kernel_modidx) && SAME_OBJ(outname, srcname))
@ -6297,6 +6314,10 @@ int compute_reprovides(Scheme_Hash_Table *_provided, Scheme_Hash_Table *_et_prov
}
}
}
if (!matching_form) {
scheme_hash_set(provided, scheme_void, provided_list);
}
}
}
@ -6376,7 +6397,7 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind
{
Scheme_Hash_Table *ht, *et_ht, *dt_ht, *_ht, *_et_ht, *_dt_ht;
Scheme_Object *l, *requires, *required, *et_required, *dt_required, *a[3];
int v, i, j, phase, inc;
int v, i, phase, inc;
_ht = scheme_make_hash_table(SCHEME_hash_ptr);
_et_ht = scheme_make_hash_table(SCHEME_hash_ptr);
@ -6423,11 +6444,16 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind
required = SCHEME_VEC_ELS(bindings)[i];
if (inc) {
if (SCHEME_FALSEP(modpath))
l = scheme_false;
else
l = scheme_make_pair(scheme_make_pair(modpath,
scheme_make_pair(scheme_false,
scheme_null)),
scheme_null);
v = compute_reprovides(ht, et_ht, dt_ht,
scheme_make_pair(scheme_make_pair(modpath,
scheme_make_pair(scheme_false,
scheme_null)),
scheme_null),
l,
requires,
(Scheme_Hash_Table *)required, (Scheme_Hash_Table *)et_required,(Scheme_Hash_Table *)dt_required,
genv, NULL, NULL, NULL,
@ -6438,13 +6464,9 @@ Scheme_Object *scheme_module_imported_list(Scheme_Env *genv, Scheme_Object *bind
if (v < 0) {
l = scheme_false;
} else {
l = scheme_null;
for (j = ht->size; j--; ) {
if (ht->vals[j]) {
l = scheme_make_pair(ht->vals[j], l);
}
}
l = scheme_hash_get(ht, scheme_void);
if (!l)
l = scheme_null;
}
a[i] = l;