From 7dc8e077ed9aa53fa6afd0f8badfed39263c0bd0 Mon Sep 17 00:00:00 2001 From: Matthew Flatt Date: Fri, 20 Mar 2009 16:59:28 +0000 Subject: [PATCH] add 'not-provide-all-defined and 'nonimal-id suport for rename transformers; fix scheme/foreign and foreign docs to use it svn: r14195 --- collects/ffi/private/objc-doc-unsafe.ss | 8 +++++- collects/scheme/foreign.ss | 8 +++++- collects/scheme/private/reqprov.ss | 11 +++++++- collects/scribblings/foreign/derived.scrbl | 4 --- collects/scribblings/foreign/foreign.scrbl | 2 +- collects/scribblings/foreign/libs.scrbl | 2 -- collects/scribblings/foreign/misc.scrbl | 2 -- collects/scribblings/foreign/pointers.scrbl | 4 --- .../scribblings/foreign/unsafe-foreign.ss | 26 ++++++++++++++++--- .../scribblings/reference/stx-trans.scrbl | 12 ++++++--- collects/scribblings/reference/syntax.scrbl | 14 +++++----- src/mzscheme/src/module.c | 12 +++++++-- src/mzscheme/src/stxobj.c | 17 ++++++++++-- 13 files changed, 90 insertions(+), 32 deletions(-) diff --git a/collects/ffi/private/objc-doc-unsafe.ss b/collects/ffi/private/objc-doc-unsafe.ss index 20ecc1eb89..6aad33ea1e 100644 --- a/collects/ffi/private/objc-doc-unsafe.ss +++ b/collects/ffi/private/objc-doc-unsafe.ss @@ -6,5 +6,11 @@ (objc-unsafe!) -(provide (protect-out (all-defined-out)) +(provide (protect-out objc_msgSend/typed + objc_msgSendSuper/typed + import-class + get-ivar set-ivar! + selector + tell tellv + define-objc-class) (all-from-out ffi/objc)) diff --git a/collects/scheme/foreign.ss b/collects/scheme/foreign.ss index 5ca2e2446e..122b11c8ba 100644 --- a/collects/scheme/foreign.ss +++ b/collects/scheme/foreign.ss @@ -51,7 +51,13 @@ stx 'to stx) ...)]) #'(begin (define-syntax id - (make-rename-transformer #'from)) + (make-rename-transformer (syntax-property + (syntax-property + #'from + 'not-provide-all-defined + #t) + 'nominal-id + 'to))) ...))]))))]))))) (provide* ctype-sizeof ctype-alignof compiler-sizeof diff --git a/collects/scheme/private/reqprov.ss b/collects/scheme/private/reqprov.ss index c1fa40a40c..a0c1aa4236 100644 --- a/collects/scheme/private/reqprov.ss +++ b/collects/scheme/private/reqprov.ss @@ -653,7 +653,16 @@ (memq 0 modes)) (map (lambda (id) (make-export id (syntax-e id) 0 #f stx)) - (filter (same-ctx? free-identifier=?) + (filter (lambda (id) + (and ((same-ctx? free-identifier=?) id) + (let-values ([(v id) (syntax-local-value/immediate + id + (lambda () (values #f #f)))]) + (not + (and (rename-transformer? v) + (syntax-property + (rename-transformer-target v) + 'not-provide-all-defined)))))) ids)) null)))])))) diff --git a/collects/scribblings/foreign/derived.scrbl b/collects/scribblings/foreign/derived.scrbl index 2b64510041..8ff776dd5a 100644 --- a/collects/scribblings/foreign/derived.scrbl +++ b/collects/scribblings/foreign/derived.scrbl @@ -64,8 +64,6 @@ obtain a tag. The tag is the string form of @schemevarfont{id}.} @subsection{Unsafe Tagged C Pointer Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc*[([(cpointer-has-tag? [cptr any/c] [tag any/c]) boolean?] [(cpointer-push-tag! [cptr any/c] [tag any/c]) void])]{ @@ -157,8 +155,6 @@ Converts the list @scheme[lst] to a C vector of the given @subsection{Unsafe C Vector Construction} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(make-cvector* [cptr any/c] [type ctype?] [length exact-nonnegative-integer?]) cvector?]{ diff --git a/collects/scribblings/foreign/foreign.scrbl b/collects/scribblings/foreign/foreign.scrbl index 880e267b93..bdc92ff4d8 100644 --- a/collects/scribblings/foreign/foreign.scrbl +++ b/collects/scribblings/foreign/foreign.scrbl @@ -5,7 +5,7 @@ @author["Eli Barzilay"] -@defmodule[scheme/foreign] +@defmodule[scheme/foreign #:use-sources ('#%foreign)] The @schememodname[scheme/foreign] library enables the direct use of C-based APIs within Scheme programs---without writing any new C diff --git a/collects/scribblings/foreign/libs.scrbl b/collects/scribblings/foreign/libs.scrbl index b3084f9dc3..d514f24f29 100644 --- a/collects/scribblings/foreign/libs.scrbl +++ b/collects/scribblings/foreign/libs.scrbl @@ -19,8 +19,6 @@ Returns @scheme[#t] if @scheme[v] is the result of @scheme[ffi-lib], @section{Unsafe Library Functions} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(ffi-lib [path (or/c path-string? #f)] [version (or/c string? (listof string?) #f) #f]) any]{ diff --git a/collects/scribblings/foreign/misc.scrbl b/collects/scribblings/foreign/misc.scrbl index cf5dd3d4f2..850e89b714 100644 --- a/collects/scribblings/foreign/misc.scrbl +++ b/collects/scribblings/foreign/misc.scrbl @@ -54,8 +54,6 @@ Like @scheme[list->cblock], but for Scheme vectors.} @section{Unsafe Miscellaneous Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(cblock->list [cblock any/c][type ctype?][length exact-nonnegative-integer?]) list?]{ diff --git a/collects/scribblings/foreign/pointers.scrbl b/collects/scribblings/foreign/pointers.scrbl index 9f4a4a47e1..5810e194a6 100644 --- a/collects/scribblings/foreign/pointers.scrbl +++ b/collects/scribblings/foreign/pointers.scrbl @@ -50,8 +50,6 @@ offset is always in bytes.} @section{Unsafe Pointer Operations} -@declare-exporting[scribblings/foreign/unsafe-foreign] - @defproc[(set-ptr-offset! [cptr cpointer?][offset exact-integer?][ctype ctype? _byte]) void?]{ @@ -209,8 +207,6 @@ can contain other information).} @section{Unsafe Memory Management} -@declare-exporting[scribblings/foreign/unsafe-foreign] - For general information on C-level memory management with PLT Scheme, see @|InsideMzScheme|. diff --git a/collects/scribblings/foreign/unsafe-foreign.ss b/collects/scribblings/foreign/unsafe-foreign.ss index 766bbdc086..e3eccbb4a8 100644 --- a/collects/scribblings/foreign/unsafe-foreign.ss +++ b/collects/scribblings/foreign/unsafe-foreign.ss @@ -1,11 +1,31 @@ #lang scheme/base - -(require scheme/foreign) +(require scheme/foreign + (for-syntax scheme/base + scheme/provide-transform)) (error 'unsafe! "only `for-label' use in the documentation") (unsafe!) -(provide (protect-out (all-defined-out)) +;; This is like `all-defined-out', but it ignores the 'not-provide-all-defined +;; property, so that the bindings introduced by `unsafe!' are exported. +(define-syntax all-unsafe-defined-out + (make-provide-transformer + (lambda (stx modes) + (syntax-case stx () + [(_) + (let-values ([(ids stx-ids) (syntax-local-module-defined-identifiers)] + [(same-ctx?) (lambda (free-identifier=?) + (lambda (id) + (free-identifier=? id + (datum->syntax + stx + (syntax-e id)))))]) + (map (lambda (id) + (make-export id (syntax-e id) 0 #f stx)) + (filter (same-ctx? free-identifier=?) + ids)))])))) + +(provide (protect-out (all-unsafe-defined-out)) (all-from-out scheme/foreign)) diff --git a/collects/scribblings/reference/stx-trans.scrbl b/collects/scribblings/reference/stx-trans.scrbl index 8da2fbfb77..b1aa58f3a2 100644 --- a/collects/scribblings/reference/stx-trans.scrbl +++ b/collects/scribblings/reference/stx-trans.scrbl @@ -110,9 +110,15 @@ expressions. Such a transformer could be written manually, but the one created by @scheme[make-rename-transformer] also causes the parser to install a @scheme[free-identifier=?] and @scheme[identifier-binding] -equivalence, as long as @scheme[id-stx] does not have a true value for the -@indexed-scheme['not-free-identifier=?] @tech{syntax property}. -In addition, the rename transformer cooperates specially with +equivalence, as long as @scheme[id-stx] does not have a true value for +the @indexed-scheme['not-free-identifier=?] @tech{syntax property}. +Also, if @scheme[id-stx] has a true value for the +@indexed-scheme['not-provide-all-defined] @tech{syntax property} and +it is bound as a module-level transformer, the bound identifier is not +exported by @scheme[all-defined-out]; the @scheme[provide] form +otherwise uses a symbol-valued @indexed-scheme['nominal-id] property +of @scheme[id-stx] to specify the ``nominal source identifier'' of the +binding. Finally, the rename transformer cooperates specially with @scheme[syntax-local-value] and @scheme[syntax-local-make-delta-introducer].} diff --git a/collects/scribblings/reference/syntax.scrbl b/collects/scribblings/reference/syntax.scrbl index e0647da100..d248ba0dd2 100644 --- a/collects/scribblings/reference/syntax.scrbl +++ b/collects/scribblings/reference/syntax.scrbl @@ -713,12 +713,14 @@ follows. @defsubform[(all-defined-out)]{ Exports all identifiers that are defined at @tech{phase level} 0 or @tech{phase level} 1 within the exporting module, and that have the same lexical context as the - @scheme[(all-defined-out)] form. The external name for each - identifier is the symbolic form of the identifier. Only identifiers - accessible from the lexical context of the @scheme[(all-defined-out)] - form are included; that is, macro-introduced imports are not - re-exported, unless the @scheme[(all-defined-out)] form was - introduced at the same time. + @scheme[(all-defined-out)] form, excluding bindings to @tech{rename + transformers} where the target identifier has the + @scheme['not-provide-all-defined] @tech{syntax property}. The + external name for each identifier is the symbolic form of the + identifier. Only identifiers accessible from the lexical context of + the @scheme[(all-defined-out)] form are included; that is, + macro-introduced imports are not re-exported, unless the + @scheme[(all-defined-out)] form was introduced at the same time. @defexamples[#:eval (syntax-eval) (module test scheme diff --git a/src/mzscheme/src/module.c b/src/mzscheme/src/module.c index 58d5157fdf..9b8a595c3c 100644 --- a/src/mzscheme/src/module.c +++ b/src/mzscheme/src/module.c @@ -157,6 +157,7 @@ static Scheme_Object *lib_symbol; static Scheme_Object *planet_symbol; static Scheme_Object *file_symbol; static Scheme_Object *module_name_symbol; +static Scheme_Object *nominal_id_symbol; /* global read-only syntax */ Scheme_Object *scheme_module_stx; @@ -566,6 +567,9 @@ void scheme_finish_kernel(Scheme_Env *env) REGISTER_SO(module_name_symbol); module_name_symbol = scheme_intern_symbol("enclosing-module-name"); + + REGISTER_SO(nominal_id_symbol); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); } int scheme_is_kernel_modname(Scheme_Object *modname) @@ -7381,7 +7385,10 @@ static Scheme_Object *extract_free_id_name(Scheme_Object *name, /* free-id=? equivalence to a name that is not necessarily imported explicitly */ if (_implicit_src) { *_implicit_src = mod; - *_implicit_src_name = id; + *_implicit_src_name = id; + name2 = scheme_stx_property(name2, nominal_id_symbol, NULL); + if (SCHEME_SYMBOLP(name2)) + *_implicit_nominal_name = name2; } *_implicit = 1; break; @@ -7468,7 +7475,8 @@ char *compute_provide_arrays(Scheme_Hash_Table *all_provided, Scheme_Hash_Table prnt_name = name; name = extract_free_id_name(name, phase, genv, 1, &implicit, - NULL, NULL, NULL, NULL, NULL); + NULL, NULL, NULL, + NULL, NULL); if (!implicit && genv diff --git a/src/mzscheme/src/stxobj.c b/src/mzscheme/src/stxobj.c index bc3b812e74..d1e811ce11 100644 --- a/src/mzscheme/src/stxobj.c +++ b/src/mzscheme/src/stxobj.c @@ -76,6 +76,7 @@ static Scheme_Object *share_symbol; /* uninterned! */ static Scheme_Object *origin_symbol; static Scheme_Object *lexical_symbol; static Scheme_Object *protected_symbol; +static Scheme_Object *nominal_id_symbol; static THREAD_LOCAL Scheme_Object *nominal_ipair_cache; @@ -544,11 +545,13 @@ void scheme_init_stx(Scheme_Env *env) REGISTER_SO(origin_symbol); REGISTER_SO(lexical_symbol); REGISTER_SO(protected_symbol); + REGISTER_SO(nominal_id_symbol); source_symbol = scheme_make_symbol("source"); /* not interned! */ share_symbol = scheme_make_symbol("share"); /* not interned! */ origin_symbol = scheme_intern_symbol("origin"); lexical_symbol = scheme_intern_symbol("lexical"); protected_symbol = scheme_intern_symbol("protected"); + nominal_id_symbol = scheme_intern_symbol("nominal-id"); REGISTER_SO(mark_id); @@ -1935,12 +1938,14 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, Scheme_Object *result; Scheme_Object *modname; Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name; + Scheme_Object *nominal_name, *nom2; Scheme_Object *mod_phase; Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; Scheme_Object *lex_env; + nom2 = scheme_stx_property(orig_id, nominal_id_symbol, NULL); + modname = scheme_stx_module_name(1, &orig_id, ((Module_Renames *)mrn)->phase, &nominal_modidx, &nominal_name, @@ -1949,6 +1954,9 @@ static Scheme_Object *extract_module_free_id_binding(Scheme_Object *mrn, &nominal_src_phase, &lex_env, _sealed); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; if (!modname) result = scheme_box(CONS(SCHEME_STX_VAL(orig_id), scheme_false)); @@ -5356,7 +5364,7 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) { Scheme_Object *bind; Scheme_Object *nominal_modidx; - Scheme_Object *nominal_name; + Scheme_Object *nominal_name, *nom2; Scheme_Object *mod_phase; Scheme_Object *src_phase_index; Scheme_Object *nominal_src_phase; @@ -5366,10 +5374,15 @@ static Scheme_Object *extract_free_id_info(Scheme_Object *id) phase = SCHEME_CDR(id); id = SCHEME_CAR(id); + nom2 = scheme_stx_property(id, nominal_id_symbol, NULL); + bind = scheme_stx_module_name(1, &id, phase, &nominal_modidx, &nominal_name, &mod_phase, &src_phase_index, &nominal_src_phase, &lex_env, NULL); + + if (SCHEME_SYMBOLP(nom2)) + nominal_name = nom2; if (!nominal_name) nominal_name = SCHEME_STX_VAL(id);