From ed536c002e3ef5a7f908584f9d50421fcac827b4 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Tue, 25 Nov 2008 17:58:21 +0000 Subject: [PATCH] scheme/package (and more int-def repairs) svn: r12589 --- collects/mzlib/unit.ss | 11 +- collects/scheme/package.ss | 162 ++++++++++++++------ collects/scribblings/reference/syntax.scrbl | 17 +- src/mzscheme/src/env.c | 52 ++++--- src/mzscheme/src/eval.c | 25 ++- src/mzscheme/src/mzmark.c | 2 + src/mzscheme/src/mzmarksrc.c | 1 + src/mzscheme/src/schpriv.h | 2 +- src/mzscheme/src/stxobj.c | 43 +++--- 9 files changed, 210 insertions(+), 105 deletions(-) diff --git a/collects/mzlib/unit.ss b/collects/mzlib/unit.ss index 698092ee6f..593155f322 100644 --- a/collects/mzlib/unit.ss +++ b/collects/mzlib/unit.ss @@ -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) diff --git a/collects/scheme/package.ss b/collects/scheme/package.ss index 0aabb74013..edb53be388 100644 --- a/collects/scheme/package.ss +++ b/collects/scheme/package.ss @@ -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))))])) + diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index ec899647fe..d55fdc6aef 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -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]} diff --git a/src/mzscheme/src/env.c b/src/mzscheme/src/env.c index 75bcbcd3b0..bb99733d51 100644 --- a/src/mzscheme/src/env.c +++ b/src/mzscheme/src/env.c @@ -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; diff --git a/src/mzscheme/src/eval.c b/src/mzscheme/src/eval.c index 859f21deea..c5180ca477 100644 --- a/src/mzscheme/src/eval.c +++ b/src/mzscheme/src/eval.c @@ -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"); } diff --git a/src/mzscheme/src/mzmark.c b/src/mzscheme/src/mzmark.c index d6f5546903..a78bf7de5e 100644 --- a/src/mzscheme/src/mzmark.c +++ b/src/mzscheme/src/mzmark.c @@ -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); diff --git a/src/mzscheme/src/mzmarksrc.c b/src/mzscheme/src/mzmarksrc.c index abf1066285..3ea084b71d 100644 --- a/src/mzscheme/src/mzmarksrc.c +++ b/src/mzscheme/src/mzmarksrc.c @@ -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); diff --git a/src/mzscheme/src/schpriv.h b/src/mzscheme/src/schpriv.h index 6e93798b60..01ea43d5b4 100644 --- a/src/mzscheme/src/schpriv.h +++ b/src/mzscheme/src/schpriv.h @@ -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); diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index 21fc4d7cb4..6d61d80535 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -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;