From 63c8b7ffde4bc2c1070774057f05d68833bf023b Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Mon, 21 Apr 2008 01:04:31 +0000 Subject: [PATCH] fix some mzc -e problems svn: r9379 --- collects/compiler/private/driver.ss | 26 +++++++++--- collects/compiler/to-core.ss | 44 ++++++++++---------- collects/scribblings/inside/memory.scrbl | 8 ++-- collects/scribblings/inside/namespaces.scrbl | 8 ++-- collects/scribblings/inside/overview.scrbl | 20 ++++----- src/mzscheme/include/scheme.h | 2 +- src/mzscheme/src/dynext.c | 4 +- src/mzscheme/src/salloc.c | 2 +- 8 files changed, 65 insertions(+), 49 deletions(-) diff --git a/collects/compiler/private/driver.ss b/collects/compiler/private/driver.ss index ddd6046170..de2939c76a 100644 --- a/collects/compiler/private/driver.ss +++ b/collects/compiler/private/driver.ss @@ -1171,8 +1171,7 @@ #f #f ; no module entries c-port)]) (fprintf c-port - "Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n" - compiler:setup-suffix) + "static Scheme_Object * do_scheme_reload(Scheme_Env * env)~n{~n") (fprintf c-port"~aScheme_Per_Load_Statics *PLS;~n" vm->c:indent-spaces) (fprintf c-port @@ -1188,9 +1187,17 @@ (fprintf c-port "}~n~n") + (fprintf c-port - "~nvoid scheme_setup~a(Scheme_Env * env)~n{~n" + "Scheme_Object * scheme_reload~a(Scheme_Env * env)~n{~n" compiler:setup-suffix) + (fprintf c-port"~areturn do_scheme_reload(env);~n" + vm->c:indent-spaces) + (fprintf c-port + "}~n~n") + + (fprintf c-port + "~nstatic void do_scheme_setup(Scheme_Env * env)~n{~n") (fprintf c-port "~ascheme_set_tail_buffer_size(~a);~n" vm->c:indent-spaces @@ -1218,14 +1225,23 @@ (fprintf c-port "}~n~n") + + (fprintf c-port + "~nvoid scheme_setup~a(Scheme_Env * env)~n{~n" + compiler:setup-suffix) + (fprintf c-port + "~ado_scheme_setup(env);~n" + vm->c:indent-spaces) + (fprintf c-port + "}~n~n") (when (string=? "" compiler:setup-suffix) (fprintf c-port "~nScheme_Object * scheme_initialize(Scheme_Env * env)~n{~n") - (fprintf c-port "~ascheme_setup~a(env);~n" + (fprintf c-port "~ado_scheme_setup~a(env);~n" vm->c:indent-spaces compiler:setup-suffix) - (fprintf c-port "~areturn scheme_reload~a(env);~n" + (fprintf c-port "~areturn do_scheme_reload~a(env);~n" vm->c:indent-spaces compiler:setup-suffix) (fprintf c-port diff --git a/collects/compiler/to-core.ss b/collects/compiler/to-core.ss index cc4b40c565..256061bfc2 100644 --- a/collects/compiler/to-core.ss +++ b/collects/compiler/to-core.ss @@ -1,4 +1,4 @@ -(module to-core mzscheme +(module to-core scheme/base (require syntax/kerncase syntax/stx mzlib/list @@ -45,25 +45,25 @@ [else (list stx)])) l))) - (define-struct lifted-info (counter id-map slot-map)) + (define-struct lifted-info ([counter #:mutable] id-map slot-map)) (define (make-vars) (make-lifted-info 0 (make-module-identifier-mapping) - (make-hash-table 'equal))) + (make-hash))) (define (is-id-ref? v) (or (identifier? v) (and (stx-pair? v) (identifier? (stx-car v)) - (module-identifier=? #'#%top (stx-car v))))) + (free-identifier=? #'#%top (stx-car v))))) (define (vars-sequence li) (let loop ([i 0]) (if (= i (lifted-info-counter li)) null - (cons (let ([v (hash-table-get (lifted-info-slot-map li) i)]) + (cons (let ([v (hash-ref (lifted-info-slot-map li) i)]) (if (is-id-ref? v) #`(#%variable-reference #,v) v)) @@ -73,7 +73,7 @@ (let loop ([i 0]) (if (= i (lifted-info-counter li)) null - (let ([v (hash-table-get (lifted-info-slot-map li) i)]) + (let ([v (hash-ref (lifted-info-slot-map li) i)]) (if (is-id-ref? v) (cons #`(#,extract-stx #,vec-id #,i) (loop (add1 i))) @@ -81,16 +81,16 @@ (define (is-run-time? stx) (not (and (stx-pair? stx) - (or (module-identifier=? #'define-syntaxes (stx-car stx)) - (module-identifier=? #'define-values-for-syntax (stx-car stx)))))) + (or (free-identifier=? #'define-syntaxes (stx-car stx)) + (free-identifier=? #'define-values-for-syntax (stx-car stx)))))) (define (has-symbol? decl magic-sym table) (cond - [(hash-table-get table decl (lambda () #f)) + [(hash-ref table decl (lambda () #f)) ;; cycle/graph #f] [else - (hash-table-put! table decl #t) + (hash-set! table decl #t) (cond [(eq? magic-sym decl) #t] @@ -108,21 +108,21 @@ (let ([magic-sym (string->symbol (format "magic~a~a" (current-seconds) (current-milliseconds)))]) - (if (has-symbol? (map syntax-object->datum decls) magic-sym (make-hash-table)) + (if (has-symbol? (map syntax->datum decls) magic-sym (make-hasheq)) (generate-magic decls) magic-sym))) (define (need-thunk? rhs) (not (and (stx-pair? rhs) - (or (module-identifier=? #'lambda (stx-car rhs)) - (module-identifier=? #'case-lambda (stx-car rhs)))))) + (or (free-identifier=? #'lambda (stx-car rhs)) + (free-identifier=? #'case-lambda (stx-car rhs)))))) (define (lift-sequence decls lookup-stx set-stx safe-vector-ref-stx extract-stx in-module? simple-constant? stop-properties) (let ([ct-vars (make-vars)] [rt-vars (make-vars)] - [compile-time (datum->syntax-object #f (gensym 'compile-time))] - [run-time (datum->syntax-object #f (gensym 'run-time))] + [compile-time (datum->syntax #f (gensym 'compile-time))] + [run-time (datum->syntax #f (gensym 'run-time))] [magic-sym (generate-magic decls)] [magic-indirect (gensym)]) (let ([ct-converted @@ -136,7 +136,7 @@ in-module? simple-constant? stop-properties)]) (if (and (not in-module?) - (module-identifier=? #'def #'define-syntaxes)) + (free-identifier=? #'def #'define-syntaxes)) ;; Don't try to name macro procedures, because it ;; inteferes with the 0-values hack at the top level cvted @@ -284,12 +284,12 @@ [(and (pair? b) (eq? '#%kernel (car b))) ;; Generate a syntax object that has the right run-time binding: - (datum->syntax-object #'here (cadr b) stx stx)] + (datum->syntax #'here (cadr b) stx stx)] [else #f]))) (define (add-literal/pos stx li) (let ([pos (lifted-info-counter li)]) - (hash-table-put! (lifted-info-slot-map li) pos stx) + (hash-set! (lifted-info-slot-map li) pos stx) (set-lifted-info-counter! li (add1 pos)) pos)) @@ -322,10 +322,10 @@ [(_ stx e) (let ([old-s stx] [new-s (quasisyntax e)]) (syntax-recertify - (datum->syntax-object new-s - (syntax-e new-s) - old-s - old-s) + (datum->syntax new-s + (syntax-e new-s) + old-s + old-s) new-s code-insp #f))])) diff --git a/collects/scribblings/inside/memory.scrbl b/collects/scribblings/inside/memory.scrbl index d9253d1297..2a717c9fc8 100644 --- a/collects/scribblings/inside/memory.scrbl +++ b/collects/scribblings/inside/memory.scrbl @@ -85,7 +85,7 @@ times). With conservative collection, no registration is needed for the global or static variables of an embedding program, unless it calls -@cpp{scheme_setup} or @cppi{scheme_set_stack_base} with a non-zero +@cpp{scheme_main_setup} or @cppi{scheme_set_stack_base} with a non-zero first or second (respectively) argument. In that case, global and static variables containing collectable pointers must be registered with @cppi{scheme_register_static}. The @cppi{MZ_REGISTER_STATIC} @@ -686,7 +686,7 @@ Registers an extension's global variable that can contain Scheme occur during the registration.} -@function[(int scheme_setup +@function[(int scheme_main_setup [int no_auto_statics] [Scheme_Main main] [int argc] @@ -704,7 +704,7 @@ typedef int (*Scheme_Main)(Scheme_Env *env, int argc, char **argv); } -The result of @var{main} is the result of @cpp{scheme_setup}. +The result of @var{main} is the result of @cpp{scheme_main_setup}. If @var{no_auto_statics} is non-zero, then static variables must be explicitly registered with the garbage collector; see @@ -739,7 +739,7 @@ must be the beginning or end of a local-frame registration. Worse, in CGC or 3m, if @cpp{real_main} is declared @cpp{static}, the compiler may inline it and place variables containing collectable values deeper in the stack than @cpp{dummy}. To avoid these problems, use -@cpp{scheme_setup}, instead.} +@cpp{scheme_main_setup}, instead.} @function[(void scheme_set_stack_bounds [void* stack_addr] diff --git a/collects/scribblings/inside/namespaces.scrbl b/collects/scribblings/inside/namespaces.scrbl index b1ab68d1ea..33d0728a83 100644 --- a/collects/scribblings/inside/namespaces.scrbl +++ b/collects/scribblings/inside/namespaces.scrbl @@ -11,10 +11,10 @@ and syntax. The @cpp{scheme_basic_env} function must be called once by an embedding program, before any other PLT Scheme function is called -(except @cpp{scheme_make_param}), but @cpp{scheme_setup} automatically -calls @cpp{scheme_basic_env}. The returned namespace is the initial -current namespace for the main Scheme thread. Scheme extensions cannot -call @cpp{scheme_basic_env}. +(except @cpp{scheme_make_param}), but @cpp{scheme_main_setup} +automatically calls @cpp{scheme_basic_env}. The returned namespace is +the initial current namespace for the main Scheme thread. Scheme +extensions cannot call @cpp{scheme_basic_env}. The current thread's current namespace is available from @cppi{scheme_get_env}, given the current parameterization (see diff --git a/collects/scribblings/inside/overview.scrbl b/collects/scribblings/inside/overview.scrbl index 0cae83ea43..568ab21c5b 100644 --- a/collects/scribblings/inside/overview.scrbl +++ b/collects/scribblings/inside/overview.scrbl @@ -296,13 +296,13 @@ To embed PLT Scheme CGC in a program, follow these steps: installing from source also places this file in the installation's @filepath{include} directory.} - @item{Start your main program through the @cpp{scheme_setup} + @item{Start your main program through the @cpp{scheme_main_setup} trampoline, and put all uses of MzScheme functions inside the - function passed to @cpp{scheme_setup}. The @cpp{scheme_setup} + function passed to @cpp{scheme_main_setup}. The @cpp{scheme_main_setup} function registers the current C stack location with the memory manager. It also creates the initial namespace @cpp{Scheme_Env*} by calling @cppi{scheme_basic_env} and passing the result to the - function provided to @cpp{scheme_setup}.} + function provided to @cpp{scheme_main_setup}.} @item{Configure the namespace by adding module declarations. The initial namespace contains declarations only for a few primitive @@ -390,13 +390,13 @@ static int run(Scheme_Env *e, int argc, char *argv[]) int main(int argc, char *argv[]) { - return scheme_setup(1, run, argc, argv); + return scheme_main_setup(1, run, argc, argv); } } Under Mac OS X, or under Windows when MzScheme is compiled to a DLL using Cygwin, the garbage collector cannot find static variables -automatically. In that case, @cppi{scheme_setup} must be called with a +automatically. In that case, @cppi{scheme_main_setup} must be called with a non-zero first argument. Under Windows (for any other build mode), the garbage collector finds @@ -404,9 +404,9 @@ static variables in an embedding program by examining all memory pages. This strategy fails if a program contains multiple Windows threads; a page may get unmapped by a thread while the collector is examining the page, causing the collector to crash. To avoid this -problem, call @cpp{scheme_setup} with a non-zero first argument. +problem, call @cpp{scheme_main_setup} with a non-zero first argument. -When an embedding application calls @cpp{scheme_setup} with a non-zero +When an embedding application calls @cpp{scheme_main_setup} with a non-zero first argument, it must register each of its static variables with @cppi{MZ_REGISTER_STATIC} if the variable can contain a GCable pointer. For example, if @cpp{curout} above is made @cpp{static}, then @@ -414,7 +414,7 @@ pointer. For example, if @cpp{curout} above is made @cpp{static}, then @cpp{scheme_get_param}. When building an embedded MzSchemeCGC to use SenoraGC (SGC) instead of -the default collector, @cpp{scheme_setup} must be called with a +the default collector, @cpp{scheme_main_setup} must be called with a non-zero first argument. See @secref["im:memoryalloc"] for more information. @@ -454,7 +454,7 @@ In addition, some library details are different: } -For MzScheme3m, an embedding application must call @cpp{scheme_setup} +For MzScheme3m, an embedding application must call @cpp{scheme_main_setup} with a non-zero first argument. The simple embedding program from the previous section can be @@ -520,7 +520,7 @@ static int run(Scheme_Env *e, int argc, char *argv[]) int main(int argc, char *argv[]) { - return scheme_setup(1, run, argc, argv); + return scheme_main_setup(1, run, argc, argv); } } diff --git a/src/mzscheme/include/scheme.h b/src/mzscheme/include/scheme.h index fd0ebd8327..1de3b1dc32 100644 --- a/src/mzscheme/include/scheme.h +++ b/src/mzscheme/include/scheme.h @@ -1696,7 +1696,7 @@ MZ_EXTERN void scheme_set_stack_bounds(void *base, void *deepest, int no_auto_st /* More automatic start-up: */ typedef int (*Scheme_Main)(Scheme_Env *env, int argc, char **argv); -MZ_EXTERN int scheme_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv); +MZ_EXTERN int scheme_main_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv); MZ_EXTERN void scheme_register_static(void *ptr, long size); diff --git a/src/mzscheme/src/dynext.c b/src/mzscheme/src/dynext.c index f0dfce34d6..3ebaed5d8c 100644 --- a/src/mzscheme/src/dynext.c +++ b/src/mzscheme/src/dynext.c @@ -266,14 +266,14 @@ static Scheme_Object *do_load_extension(const char *filename, "load-extension: bad version %s (not %s) from \"%s\"", vers, VERSION_AND_VARIANT, filename); } - + init_f = (Init_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_initialize"); if (init_f) { reload_f = (Reload_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_reload"); if (reload_f) modname_f = (Modname_Procedure)dlsym(dl, SO_SYMBOL_PREFIX "scheme_module_name"); } - + if (!init_f || !reload_f || !modname_f) { const char *err; err = dlerror(); diff --git a/src/mzscheme/src/salloc.c b/src/mzscheme/src/salloc.c index 3226767d27..1223865fea 100644 --- a/src/mzscheme/src/salloc.c +++ b/src/mzscheme/src/salloc.c @@ -88,7 +88,7 @@ void scheme_set_stack_base(void *base, int no_auto_statics) use_registered_statics = no_auto_statics; } -int scheme_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv) +int scheme_main_setup(int no_auto_statics, Scheme_Main _main, int argc, char **argv) { void *start_addr = &start_addr;