828 lines
35 KiB
Scheme
828 lines
35 KiB
Scheme
(module reqprov '#%kernel
|
|
(#%require "more-scheme.ss" "small-scheme.ss" "define.ss" "../stxparam.ss"
|
|
(for-syntax '#%kernel "define.ss"
|
|
"stx.ss" "stxcase-scheme.ss" "small-scheme.ss"
|
|
"stxloc.ss" "qqstx.ss"
|
|
"../require-transform.ss"
|
|
"../provide-transform.ss"
|
|
"struct-info.ss"))
|
|
|
|
(#%provide lib file planet
|
|
for-syntax for-template for-label
|
|
require
|
|
only-in rename-in prefix-in except-in
|
|
provide
|
|
all-defined-out all-from-out
|
|
rename-out except-out prefix-out struct-out
|
|
protect-out)
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; helpers
|
|
|
|
(define-for-syntax (filter pred l)
|
|
(cond
|
|
[(null? l) null]
|
|
[(pred (car l)) (cons (car l) (filter pred (cdr l)))]
|
|
[else (filter pred (cdr l))]))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; lib
|
|
|
|
(define-for-syntax (check-lib-form stx)
|
|
(unless (module-path? (syntax->datum stx))
|
|
(raise-syntax-error
|
|
#f
|
|
"ill-formed module path"
|
|
stx)))
|
|
|
|
(define-syntaxes (lib file planet)
|
|
(let ([t
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(check-lib-form stx)
|
|
(let*-values ([(mod-path) (syntax->datum stx)]
|
|
[(names et-names lt-names) (syntax-local-module-exports stx)])
|
|
(values
|
|
(apply
|
|
append
|
|
(map (lambda (names mode)
|
|
(map (lambda (name)
|
|
(make-import (datum->syntax
|
|
stx
|
|
name
|
|
stx)
|
|
name
|
|
mod-path
|
|
mode
|
|
'run
|
|
stx))
|
|
names))
|
|
(list names et-names lt-names)
|
|
(list 'run 'syntax 'label)))
|
|
(list (make-import-source stx 'run))))))])
|
|
(values t t t)))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; for-syntax, for-template, for-label
|
|
|
|
(define-for-syntax (shift-subs stx mode)
|
|
(syntax-case stx ()
|
|
[(_ in ...)
|
|
(let* ([imports+sourcess
|
|
(map (lambda (in)
|
|
(let-values ([(imports sources) (expand-import in)])
|
|
(cons imports sources)))
|
|
(syntax->list #'(in ...)))]
|
|
[imports (apply append (map car imports+sourcess))]
|
|
[sources (apply append (map cdr imports+sourcess))])
|
|
(values (map (lambda (import)
|
|
(make-import (import-local-id import)
|
|
(import-src-sym import)
|
|
(import-src-mod-path import)
|
|
mode
|
|
mode
|
|
(import-orig-stx import)))
|
|
(filter (lambda (import)
|
|
(eq? (import-mode import) 'run))
|
|
imports))
|
|
(map (lambda (source)
|
|
(make-import-source (import-source-mod-path-stx source)
|
|
mode))
|
|
(filter (lambda (source)
|
|
(eq? (import-source-mode source) 'run))
|
|
sources))))]))
|
|
|
|
(define-for-syntax (make-require+provide-transformer r p)
|
|
(let-values ([(s: mk s? s-ref s-set!)
|
|
(make-struct-type 'req+prov
|
|
#f
|
|
0 0 #f
|
|
(list
|
|
(cons prop:require-transformer (lambda (a) r))
|
|
(cons prop:provide-transformer (lambda (a) p))))])
|
|
(mk)))
|
|
|
|
(define-for-syntax (exports-at-phase stx modes mode)
|
|
(if (not (null? modes))
|
|
(raise-syntax-error
|
|
#f
|
|
"nested phases specification not allowed"
|
|
stx)
|
|
(syntax-case stx ()
|
|
[(_ ex ...)
|
|
(apply append
|
|
(map (lambda (ex)
|
|
(expand-export ex (list mode)))
|
|
(syntax->list #'(ex ...))))])))
|
|
|
|
(define-syntax for-syntax
|
|
(make-require+provide-transformer
|
|
(lambda (stx)
|
|
(shift-subs stx 'syntax))
|
|
(lambda (stx modes)
|
|
(exports-at-phase stx modes 'syntax))))
|
|
|
|
(define-syntax for-template
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(shift-subs stx 'template))))
|
|
|
|
(define-syntax for-label
|
|
(make-require+provide-transformer
|
|
(lambda (stx)
|
|
(shift-subs stx 'label))
|
|
(lambda (stx modes)
|
|
(exports-at-phase stx modes 'label))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; require
|
|
|
|
(define-syntax (require stx)
|
|
(unless (memq (syntax-local-context) '(module module-begin top-level))
|
|
(raise-syntax-error #f
|
|
"not at module level or top level"
|
|
stx))
|
|
(letrec ([mode-wrap
|
|
(lambda (mode base)
|
|
(cond
|
|
[(eq? mode 'run) base]
|
|
[(eq? mode 'syntax) #`(for-syntax #,base)]
|
|
[(eq? mode 'template) #`(for-template #,base)]
|
|
[(eq? mode 'label) #`(for-label #,base)]
|
|
[else (error "huh?" mode)]))]
|
|
[simple-path? (lambda (p)
|
|
(syntax-case p (lib)
|
|
[(lib s)
|
|
(check-lib-form p)]
|
|
[_
|
|
(or (identifier? p)
|
|
(and (string? (syntax-e p))
|
|
(module-path? (syntax-e p))))]))]
|
|
[transform-simple
|
|
(lambda (in base-mode)
|
|
(syntax-case in (lib file planet prefix-in except-in)
|
|
;; Detect simple cases first:
|
|
[_
|
|
(string? (syntax-e in))
|
|
(begin
|
|
(unless (module-path? (syntax-e in))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad module-path string"
|
|
stx
|
|
in))
|
|
(list (mode-wrap base-mode in)))]
|
|
[_
|
|
(identifier? in)
|
|
(list (mode-wrap base-mode in))]
|
|
[(lib . s)
|
|
(check-lib-form in)
|
|
(list (mode-wrap base-mode in))]
|
|
[(file . s)
|
|
(check-lib-form in)
|
|
(list (mode-wrap base-mode in))]
|
|
[(planet . s)
|
|
(check-lib-form in)
|
|
(list (mode-wrap base-mode in))]
|
|
[(prefix-in pfx path)
|
|
(simple-path? #'path)
|
|
(list (mode-wrap
|
|
base-mode
|
|
(datum->syntax
|
|
#'path
|
|
(syntax-e
|
|
(quasisyntax
|
|
(prefix pfx path)))
|
|
in
|
|
in)))]
|
|
[(except-in path id ...)
|
|
(and (simple-path? #'path)
|
|
;; check that it's well-formed...
|
|
(call-with-values (lambda () (expand-import in))
|
|
(lambda (a b) #t))
|
|
(list (mode-wrap
|
|
base-mode
|
|
(datum->syntax
|
|
#'path
|
|
(syntax-e
|
|
(quasisyntax/loc in
|
|
(all-except path id ...)))))))]
|
|
;; General case:
|
|
[_ (let-values ([(imports sources) (expand-import in)])
|
|
;; TODO: collapse back to simple cases when possible
|
|
(append
|
|
(map (lambda (import)
|
|
(mode-wrap (if (eq? base-mode 'run)
|
|
(import-req-mode import)
|
|
base-mode)
|
|
#`(rename #,(import-src-mod-path import)
|
|
#,(import-local-id import)
|
|
#,(import-src-sym import))))
|
|
(if (eq? base-mode 'run)
|
|
imports
|
|
(filter (lambda (import)
|
|
(eq? (import-mode import) 'run))
|
|
imports)))
|
|
(map (lambda (src)
|
|
(mode-wrap (if (eq? base-mode 'run)
|
|
(import-source-mode src)
|
|
base-mode)
|
|
#`(only #,(import-source-mod-path-stx src))))
|
|
(if (eq? base-mode 'run)
|
|
sources
|
|
(filter (lambda (source)
|
|
(eq? (import-source-mode source) 'run))
|
|
sources)))))]))]
|
|
[transform-one
|
|
(lambda (in)
|
|
;; Recognize `for-syntax', etc. for simple cases:
|
|
(syntax-case in ()
|
|
[(for-something elem ...)
|
|
(and (identifier? #'for-something)
|
|
(ormap (lambda (i) (free-identifier=? i #'for-something))
|
|
(list #'for-syntax #'for-template #'for-label)))
|
|
(apply append
|
|
(map (lambda (in)
|
|
(transform-simple in
|
|
(cond
|
|
[(free-identifier=? #'for-something #'for-syntax)
|
|
'syntax]
|
|
[(free-identifier=? #'for-something #'for-template)
|
|
'template]
|
|
[(free-identifier=? #'for-something #'for-label)
|
|
'label])))
|
|
(syntax->list #'(elem ...))))]
|
|
[_ (transform-simple in 'run)]))])
|
|
(syntax-case stx ()
|
|
[(_ in ...)
|
|
(with-syntax ([(new-in ...)
|
|
(apply append
|
|
(map transform-one (syntax->list #'(in ...))))])
|
|
(syntax/loc stx
|
|
(#%require new-in ...)))])))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; require transformers
|
|
|
|
(define-syntax only-in
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ in id ...)
|
|
(let-values ([(imports sources) (expand-import #'in)]
|
|
[(ids) (syntax->list #'(id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (or (identifier? id)
|
|
(let ([l (syntax->list id)])
|
|
(and l
|
|
(= 2 (length l))
|
|
(identifier? (car l))
|
|
(identifier? (cadr l)))))
|
|
(raise-syntax-error
|
|
#f
|
|
"expected <id> or [<id> <id>], but found something else"
|
|
stx
|
|
id)))
|
|
ids)
|
|
(let ([orig-ids (map (lambda (id)
|
|
(if (identifier? id)
|
|
id
|
|
(car (syntax-e id))))
|
|
ids)]
|
|
[new-ids (map (lambda (id)
|
|
(if (identifier? id)
|
|
id
|
|
(cadr (syntax->list id))))
|
|
ids)])
|
|
(let ([dup-id (check-duplicate-identifier new-ids)])
|
|
(when dup-id
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
dup-id)))
|
|
(values
|
|
(map (lambda (new-id orig-id)
|
|
(or (ormap (lambda (import)
|
|
(and (free-identifier=? orig-id
|
|
(import-local-id import))
|
|
(if (eq? new-id orig-id)
|
|
import
|
|
(make-import new-id
|
|
(import-src-sym import)
|
|
(import-src-mod-path import)
|
|
(import-mode import)
|
|
(import-req-mode import)
|
|
new-id))))
|
|
imports)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "identifier `~a' not included in nested require spec"
|
|
(syntax-e orig-id))
|
|
stx
|
|
#'in)))
|
|
new-ids orig-ids)
|
|
sources)))]))))
|
|
|
|
(define-syntax except-in
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ in id ...)
|
|
(let-values ([(imports sources) (expand-import #'in)]
|
|
[(ids) (syntax->list #'(id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected <id>, but found something else"
|
|
stx
|
|
id)))
|
|
ids)
|
|
(let ([dup-id (check-duplicate-identifier ids)])
|
|
(when dup-id
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
dup-id)))
|
|
(for-each (lambda (id)
|
|
(or (ormap (lambda (import)
|
|
(free-identifier=? id (import-local-id import)))
|
|
imports)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "identifier `~a' not included in nested require spec"
|
|
(syntax-e id))
|
|
stx
|
|
#'in)))
|
|
ids)
|
|
(values
|
|
(filter (lambda (import)
|
|
(not (ormap (lambda (id)
|
|
(free-identifier=? id (import-local-id import)))
|
|
ids)))
|
|
imports)
|
|
sources))]))))
|
|
|
|
(define-syntax rename-in
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ in [orig-id bind-id] ...)
|
|
(let-values ([(imports sources) (expand-import #'in)]
|
|
[(orig-ids) (syntax->list #'(orig-id ...))]
|
|
[(bind-ids) (syntax->list #'(bind-id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier, but found something else"
|
|
stx
|
|
id)))
|
|
(append orig-ids bind-ids))
|
|
(let ([dup-id (check-duplicate-identifier bind-ids)])
|
|
(when dup-id
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
dup-id)))
|
|
(let ([new+olds
|
|
(map (lambda (orig-id bind-id)
|
|
(let ([import (ormap (lambda (import)
|
|
(and (free-identifier=? orig-id
|
|
(import-local-id import))
|
|
import))
|
|
imports)])
|
|
(unless import
|
|
(raise-syntax-error
|
|
#f
|
|
(format "identifier `~a' not included in nested require spec"
|
|
(syntax-e orig-id))
|
|
stx
|
|
#'in))
|
|
(cons (make-import bind-id
|
|
(import-src-sym import)
|
|
(import-src-mod-path import)
|
|
(import-mode import)
|
|
(import-req-mode import)
|
|
bind-id)
|
|
import)))
|
|
orig-ids bind-ids)])
|
|
(let ([leftover-imports
|
|
(let ([ht (make-immutable-hash-table
|
|
(map (lambda (v) (cons (cdr v) #f))
|
|
new+olds))])
|
|
(filter (lambda (i) (hash-table-get ht i #t)) imports))])
|
|
;; Make sure no new name is in the leftover set:
|
|
(for-each (lambda (bind-id)
|
|
(when (ormap (lambda (import)
|
|
(and (free-identifier=? bind-id
|
|
(import-local-id import))
|
|
import))
|
|
leftover-imports)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "identifier `~a' already in nested require spec"
|
|
(syntax-e bind-id))
|
|
stx
|
|
#'in)))
|
|
bind-ids)
|
|
(values
|
|
(append
|
|
(map car new+olds)
|
|
leftover-imports)
|
|
sources))))]))))
|
|
|
|
(define-syntax prefix-in
|
|
(make-require-transformer
|
|
(lambda (stx)
|
|
(syntax-case stx ()
|
|
[(_ pfx in)
|
|
(let-values ([(imports sources) (expand-import #'in)]
|
|
[(pfx) #'pfx])
|
|
(unless (identifier? #'pfx)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an <id> for prefix, found something else"
|
|
stx
|
|
#'pfx))
|
|
(values
|
|
(map (lambda (import)
|
|
(let ([id (import-local-id import)])
|
|
(make-import (datum->syntax
|
|
id
|
|
(string->symbol
|
|
(format "~a~a"
|
|
(syntax-e pfx)
|
|
(syntax-e id)))
|
|
id
|
|
id)
|
|
(import-src-sym import)
|
|
(import-src-mod-path import)
|
|
(import-mode import)
|
|
(import-req-mode import)
|
|
(import-orig-stx import))))
|
|
imports)
|
|
sources))]))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; provide
|
|
|
|
(define-syntax (provide stx)
|
|
(unless (memq (syntax-local-context) '(module module-begin))
|
|
(raise-syntax-error #f
|
|
"not at module level"
|
|
stx))
|
|
|
|
(syntax-case stx ()
|
|
[(_ out ...)
|
|
(syntax-property
|
|
(quasisyntax/loc stx
|
|
(#%provide #,(syntax-property
|
|
#`(expand (provide-trampoline out ...))
|
|
'certify-mode 'transparent)))
|
|
'certify-mode 'transparent)]))
|
|
|
|
(define-syntax (provide-trampoline stx)
|
|
(syntax-case stx ()
|
|
[(_ out ...)
|
|
(letrec ([transform-simple
|
|
(lambda (out)
|
|
(let ([exports (expand-export out null)])
|
|
(map (lambda (export)
|
|
(let ([base
|
|
(if (eq? (syntax-e (export-local-id export))
|
|
(export-out-sym export))
|
|
(export-local-id export)
|
|
#`(rename #,(export-local-id export)
|
|
#,(export-out-sym export)))]
|
|
[mode (export-mode export)])
|
|
(let ([phased
|
|
(cond
|
|
[(eq? mode 'run) base]
|
|
[(eq? mode 'syntax) #`(for-syntax #,base)]
|
|
[(eq? mode 'label) #`(for-label #,base)])])
|
|
(if (export-protect? export)
|
|
#`(protect #,phased)
|
|
phased))))
|
|
exports)))])
|
|
(syntax-case stx ()
|
|
[(_ out ...)
|
|
(with-syntax ([(new-out ...)
|
|
(apply append
|
|
(map transform-simple (syntax->list #'(out ...))))])
|
|
(syntax/loc stx
|
|
(begin new-out ...)))]))]))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
;; provide transformers
|
|
|
|
(define-syntax all-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)))))])
|
|
(append
|
|
(if (memq 'syntax modes)
|
|
(map (lambda (id)
|
|
(make-export id (syntax-e id) 'syntax #f stx))
|
|
(filter (same-ctx? free-transformer-identifier=?)
|
|
stx-ids))
|
|
null)
|
|
(if (or (null? modes)
|
|
(memq 'run modes))
|
|
(map (lambda (id)
|
|
(make-export id (syntax-e id) 'run #f stx))
|
|
(filter (same-ctx? free-identifier=?)
|
|
ids))
|
|
null)))]))))
|
|
|
|
(define-syntax all-from-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(syntax-case stx ()
|
|
[(_ mp ...)
|
|
(apply
|
|
append
|
|
(map
|
|
(lambda (mp)
|
|
(unless (module-path? (syntax->datum mp))
|
|
(raise-syntax-error
|
|
#f
|
|
"bad module path"
|
|
stx
|
|
mp))
|
|
(let-values ([(ids stx-ids label-ids)
|
|
(syntax-local-module-required-identifiers (syntax->datum mp)
|
|
(or (null? modes)
|
|
(memq 'run modes))
|
|
(memq 'syntax modes)
|
|
(memq 'label modes))])
|
|
(when (or (null? modes)
|
|
(memq 'run modes))
|
|
(unless ids
|
|
(raise-syntax-error
|
|
#f
|
|
"no corresponding require"
|
|
stx
|
|
mp)))
|
|
(when (memq 'syntax modes)
|
|
(unless stx-ids
|
|
(raise-syntax-error
|
|
#f
|
|
"no corresponding for-syntax require"
|
|
stx
|
|
mp)))
|
|
(when (memq 'label modes)
|
|
(unless label-ids
|
|
(raise-syntax-error
|
|
#f
|
|
"no corresponding for-label require"
|
|
stx
|
|
mp)))
|
|
(append
|
|
(map (lambda (id)
|
|
(make-export id (syntax-e id) 'syntax #f stx))
|
|
(if (or (null? modes)
|
|
(memq 'syntax modes))
|
|
(or stx-ids null)
|
|
null))
|
|
(map (lambda (id)
|
|
(make-export id (syntax-e id) 'label #f stx))
|
|
(if (or (null? modes)
|
|
(memq 'label modes))
|
|
(or label-ids null)
|
|
null))
|
|
(map (lambda (id)
|
|
(make-export id (syntax-e id) 'run #f stx))
|
|
(if (or (null? modes)
|
|
(memq 'run modes))
|
|
ids
|
|
null)))))
|
|
(syntax->list #'(mp ...))))]))))
|
|
|
|
(define-syntax rename-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(syntax-case stx ()
|
|
[(_ [orig-id bind-id] ...)
|
|
(let ([orig-ids (syntax->list #'(orig-id ...))]
|
|
[bind-ids (syntax->list #'(bind-id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier, but found something else"
|
|
stx
|
|
id)))
|
|
(append orig-ids bind-ids))
|
|
(apply
|
|
append
|
|
(map (lambda (mode identifier-binding env-desc)
|
|
(map (lambda (orig-id bind-id)
|
|
(unless (list? (identifier-binding orig-id))
|
|
(raise-syntax-error
|
|
#f
|
|
(format "no binding~a for identifier" env-desc)
|
|
stx
|
|
orig-id))
|
|
(make-export orig-id
|
|
(syntax-e bind-id)
|
|
mode
|
|
#f
|
|
bind-id))
|
|
orig-ids bind-ids))
|
|
(if (null? modes)
|
|
'(run)
|
|
modes)
|
|
(if (null? modes)
|
|
(list identifier-binding)
|
|
(map (lambda (mode)
|
|
(cond
|
|
[(eq? mode 'run) identifier-binding]
|
|
[(eq? mode 'syntax) identifier-transformer-binding]
|
|
[(eq? mode 'label) identifier-label-binding]))
|
|
modes))
|
|
(if (null? modes)
|
|
(list "")
|
|
(map (lambda (mode)
|
|
(cond
|
|
[(eq? mode 'run) ""]
|
|
[(eq? mode 'syntax) " for-syntax"]
|
|
[(eq? mode 'label) " for-label"]))
|
|
modes)))))]))))
|
|
|
|
(define-syntax except-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(syntax-case stx ()
|
|
[(_ out id ...)
|
|
(let ([exports (expand-export #'out modes)]
|
|
[ids (syntax->list #'(id ...))])
|
|
(for-each (lambda (id)
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected <id>, but found something else"
|
|
stx
|
|
id)))
|
|
ids)
|
|
(let ([dup-id (check-duplicate-identifier ids)])
|
|
(when dup-id
|
|
(raise-syntax-error
|
|
#f
|
|
"duplicate identifier"
|
|
stx
|
|
dup-id)))
|
|
(map (lambda (id)
|
|
(or (ormap (lambda (export)
|
|
(free-identifier=? id (export-local-id export)))
|
|
exports)
|
|
(raise-syntax-error
|
|
#f
|
|
(format "identifier `~a' not included in nested provide spec"
|
|
(syntax-e id))
|
|
stx
|
|
#'out)))
|
|
ids)
|
|
(filter (lambda (export)
|
|
(not (ormap (lambda (id)
|
|
((let ([mode (export-mode export)])
|
|
(cond
|
|
[(eq? mode 'run) free-identifier=?]
|
|
[(eq? mode 'syntax) free-transformer-identifier=?]
|
|
[(eq? mode 'label) free-label-identifier=?]))
|
|
id
|
|
(export-local-id export)))
|
|
ids)))
|
|
exports))]))))
|
|
|
|
(define-for-syntax (build-name id . parts)
|
|
(datum->syntax
|
|
id
|
|
(string->symbol
|
|
(apply string-append
|
|
(map (lambda (p)
|
|
(if (syntax? p)
|
|
(symbol->string (syntax-e p))
|
|
p))
|
|
parts)))
|
|
id))
|
|
|
|
(define-syntax struct-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(unless (or (null? modes)
|
|
(memq 'run modes))
|
|
(raise-syntax-error
|
|
#f
|
|
"allowed only for run-time bindings"
|
|
stx))
|
|
(syntax-case stx ()
|
|
[(_ id)
|
|
(let ([id #'id])
|
|
(unless (identifier? id)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an identifier for a struct-type name, but found something else"
|
|
id
|
|
stx))
|
|
(let ([v (syntax-local-value id (lambda () #f))])
|
|
(if (struct-info? v)
|
|
(let* ([v (extract-struct-info v)]
|
|
[super-v (let ([super-id (list-ref v 5)])
|
|
(and (identifier? super-id)
|
|
(let ([super-v (syntax-local-value super-id (lambda () #f))])
|
|
(and (struct-info? super-v)
|
|
(extract-struct-info super-v)))))]
|
|
[list-ize (lambda (ids super-ids)
|
|
(let loop ([ids ids])
|
|
(cond
|
|
[(not (pair? ids)) null]
|
|
[(and (pair? super-ids)
|
|
(car ids)
|
|
(free-identifier=? (car ids)
|
|
(car super-ids)))
|
|
;; stop because we got to ids that belong to the supertype
|
|
null]
|
|
[else (cons (car ids) (loop (cdr ids)))])))])
|
|
(filter
|
|
values
|
|
(map (lambda (id)
|
|
(and id
|
|
(make-export id
|
|
(syntax-e id)
|
|
'run
|
|
#f
|
|
id)))
|
|
(append
|
|
(list id
|
|
(list-ref v 0)
|
|
(list-ref v 1)
|
|
(list-ref v 2))
|
|
(list-ize (list-ref v 3)
|
|
(and super-v
|
|
(list-ref super-v 3)))
|
|
(list-ize (list-ref v 4)
|
|
(and super-v
|
|
(list-ref super-v 3)))))))
|
|
(raise-syntax-error
|
|
#f
|
|
"identifier is not bound to struct type information"
|
|
stx
|
|
id))))]))))
|
|
|
|
(define-syntax protect-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(syntax-case stx ()
|
|
[(_ out ...)
|
|
(let ([exports (apply
|
|
append
|
|
(map (lambda (out)
|
|
(expand-export out modes))
|
|
(syntax->list #'(out ...))))])
|
|
(map (lambda (e)
|
|
(make-export
|
|
(export-local-id e)
|
|
(export-out-sym e)
|
|
(export-mode e)
|
|
#t
|
|
(export-orig-stx e)))
|
|
exports))]))))
|
|
|
|
(define-syntax prefix-out
|
|
(make-provide-transformer
|
|
(lambda (stx modes)
|
|
(syntax-case stx ()
|
|
[(_ pfx out)
|
|
(let ([exports (expand-export #'out modes)])
|
|
(unless (identifier? #'pfx)
|
|
(raise-syntax-error
|
|
#f
|
|
"expected an <id> for prefix, found something else"
|
|
stx
|
|
#'pfx))
|
|
(map (lambda (e)
|
|
(make-export
|
|
(export-local-id e)
|
|
(string->symbol (format "~s~s"
|
|
(syntax-e #'pfx)
|
|
(export-out-sym e)))
|
|
(export-mode e)
|
|
(export-protect? e)
|
|
(export-orig-stx e)))
|
|
exports))]))))
|
|
|
|
;; ;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;
|
|
)
|