225 lines
10 KiB
Scheme
225 lines
10 KiB
Scheme
(module structure mzscheme
|
|
(require (lib "etc.ss"))
|
|
(require-for-syntax "private/structure-helper.ss"
|
|
(lib "kerncase.ss" "syntax")
|
|
(lib "stx.ss" "syntax")
|
|
(lib "list.ss"))
|
|
|
|
(provide structure dot open open-in-context open-as)
|
|
|
|
;; Dangerous, but seems to work.
|
|
(define-syntax define-syntaxes-ml
|
|
(syntax-rules ()
|
|
((_ . x) (define-syntaxes . x))))
|
|
|
|
(define-syntax-set (structure)
|
|
|
|
(define kernel-form-identifier-list/no-begin
|
|
(append (map (lambda (x) (datum->syntax-object #'here x))
|
|
`(define-values-ml define-syntaxes-ml))
|
|
(filter (lambda (id) (not (eq? 'begin (syntax-e id))))
|
|
(kernel-form-identifier-list #'here))))
|
|
|
|
(define (stx-assoc id renames)
|
|
(cond
|
|
((null? renames) #f)
|
|
((bound-identifier=? id (caar renames)) (car renames))
|
|
(else (stx-assoc id (cdr renames)))))
|
|
|
|
(define (remove-begins def)
|
|
(kernel-syntax-case def #f
|
|
((begin defs ...)
|
|
(apply append (map remove-begins (syntax->list #'(defs ...)))))
|
|
(_ (list def))))
|
|
|
|
(define (fix-expr e)
|
|
(kernel-syntax-case e #f
|
|
((define-values x y) e)
|
|
((define-syntaxes x y) e)
|
|
((d x y) (or (module-identifier=? (quote-syntax define-values-ml) #'d)
|
|
(module-identifier=? (quote-syntax define-syntaxes-ml) #'d))
|
|
e)
|
|
(x #`(define-values () (begin x (values))))))
|
|
|
|
(define (get-defs defs)
|
|
(map fix-expr
|
|
(apply append
|
|
(map (lambda (d)
|
|
(remove-begins
|
|
(local-expand d
|
|
(syntax-local-context)
|
|
kernel-form-identifier-list/no-begin)))
|
|
defs))))
|
|
|
|
(define (get-ids def)
|
|
(kernel-syntax-case def #f
|
|
((define-syntaxes vars body) (syntax->list #'vars))
|
|
((define-values vars body) (syntax->list #'vars))
|
|
((d vars body) (or (module-identifier=? (quote-syntax define-values-ml) #'d)
|
|
(module-identifier=? (quote-syntax define-syntaxes-ml) #'d))
|
|
(syntax->list #'vars))
|
|
(_ (raise-syntax-error 'structure "Internal error" def))))
|
|
|
|
(define (rebuild ctxt val)
|
|
(if (syntax? ctxt)
|
|
(datum->syntax-object ctxt val ctxt ctxt)
|
|
val))
|
|
|
|
(define (rebuild-cons car cdr stx)
|
|
(rebuild stx (cons car cdr)))
|
|
|
|
(define (mark-ids def introducers)
|
|
(let ((new-ids (map (lambda (id) (cons id (make-syntax-introducer)))
|
|
(get-ids def))))
|
|
(values
|
|
(syntax-case def ()
|
|
((ds . x) (module-identifier=? (quote-syntax define-syntaxes) #'ds)
|
|
(rebuild-cons #'ds (mark-ids-helper #'x (append new-ids introducers)) def))
|
|
((dv . x) (module-identifier=? (quote-syntax define-values) #'dv)
|
|
(rebuild-cons #'dv (mark-ids-helper #'x (append new-ids introducers)) def))
|
|
((d vars body) (module-identifier=? (quote-syntax define-values-ml) #'d)
|
|
(rebuild def `(,(datum->syntax-object #'here 'define-values #'d #'d)
|
|
,(mark-ids-helper #'vars (append new-ids introducers))
|
|
,(mark-ids-helper #'body introducers))))
|
|
((d vars body) (module-identifier=? (quote-syntax define-syntaxes-ml) #'d)
|
|
(rebuild def `(,(datum->syntax-object #'here 'define-syntaxes #'d #'d)
|
|
,(mark-ids-helper #'vars (append new-ids introducers))
|
|
,(mark-ids-helper #'body introducers)))))
|
|
new-ids)))
|
|
|
|
(define (mark-ids-helper def introducers)
|
|
(let ((contents
|
|
(if (syntax? def)
|
|
(syntax-e def)
|
|
def)))
|
|
(cond
|
|
((symbol? contents)
|
|
(let ((introducer (stx-assoc def introducers)))
|
|
(if introducer ((cdr introducer) def) def)))
|
|
((pair? contents)
|
|
(rebuild-cons (mark-ids-helper (car contents) introducers)
|
|
(mark-ids-helper (cdr contents) introducers)
|
|
def))
|
|
((vector? contents)
|
|
(rebuild def (list->vector
|
|
(map (lambda (x) (mark-ids-helper x introducers))
|
|
(vector->list contents)))))
|
|
(else def))))
|
|
|
|
(define (structure/proc stx)
|
|
(syntax-case stx ()
|
|
((_ name provides body ...)
|
|
(let ((defs (get-defs (syntax->list #'(body ...)))))
|
|
(unless (identifier? #'name)
|
|
(raise-syntax-error 'structure "Structure name must be an identifier" #'name))
|
|
#`(begin
|
|
#,@(let loop ((defined-ids null)
|
|
(defs defs))
|
|
(cond
|
|
((null? defs)
|
|
(list
|
|
#`(define-syntaxes-ml (name)
|
|
(make-str
|
|
(remove-dups
|
|
(list
|
|
#,@(syntax-case #'provides ()
|
|
(all (and (identifier? #'all)
|
|
(module-identifier=? (quote-syntax provide-all)
|
|
#'all))
|
|
(map (lambda (id)
|
|
`(cons
|
|
(quote ,(car id))
|
|
(quote-syntax ,((cdr id)
|
|
(car id)))))
|
|
(filter (lambda (id)
|
|
(bound-identifier=?
|
|
(car id)
|
|
(datum->syntax-object
|
|
#'provides
|
|
(syntax-object->datum (car id)))))
|
|
defined-ids)))
|
|
((provides ...)
|
|
(map (lambda (provide)
|
|
(let ((introducer (stx-assoc provide defined-ids)))
|
|
(unless introducer
|
|
(raise-syntax-error
|
|
'structure
|
|
"Attempt to export undefined identifier"
|
|
provide))
|
|
`(cons
|
|
(quote ,provide)
|
|
(quote-syntax ,((cdr introducer) provide)))))
|
|
(syntax->list #'(provides ...))))
|
|
(p
|
|
(cond
|
|
((eq? 'provide-all (syntax-e #'p))
|
|
(raise-syntax-error
|
|
'structure
|
|
"provide-all has been rebound"
|
|
#'provides))
|
|
(else
|
|
(raise-syntax-error
|
|
'structure
|
|
"Export must have the form \"provide-all\" or \"(identifier ...)\""
|
|
#'provides)))))))))))
|
|
(else
|
|
(let-values (((marked-def new-defined-ids)
|
|
(mark-ids (car defs) defined-ids)))
|
|
(cons marked-def
|
|
(loop (append new-defined-ids defined-ids)
|
|
(cdr defs))))))))))))
|
|
)
|
|
|
|
(define-syntax (open stx)
|
|
(syntax-case stx ()
|
|
((_ top-name path ...)
|
|
(datum->syntax-object #'here
|
|
`(open-in-context ,#'top-name ,#'top-name ,@(syntax->list #'(path ...)))
|
|
stx))))
|
|
|
|
(define-syntax (open-in-context stx)
|
|
(syntax-case stx ()
|
|
((_ context top-name path ...)
|
|
(let ((env (open (cons #'top-name (syntax->list #'(path ...))) 'open)))
|
|
(with-syntax ((((pub . hid) ...)
|
|
(map (lambda (x)
|
|
(cons (datum->syntax-object #'context (car x) stx)
|
|
(cdr x)))
|
|
env)))
|
|
#`(define-syntaxes-ml (pub ...)
|
|
(values (make-rename-transformer (quote-syntax hid)) ...)))))))
|
|
|
|
|
|
(define-syntax (dot-helper stx)
|
|
(syntax-case stx ()
|
|
((_ path field)
|
|
(begin
|
|
(unless (identifier? #'field)
|
|
(raise-syntax-error 'dot "Field to open must be an identifier" #'field))
|
|
(cond
|
|
((stx-null? #'path) #'field)
|
|
(else
|
|
(let ((hid (assq (syntax-object->datum #'field)
|
|
(open (stx->list #'path) 'dot))))
|
|
(unless hid
|
|
(raise-syntax-error 'dot "Unknown field" #'field))
|
|
(cdr hid))))))))
|
|
|
|
(define-syntax (dot stx)
|
|
(syntax-case stx ()
|
|
((_ path1 path-rest ...)
|
|
(let*-values (((path field)
|
|
(split (cons #'path1 (syntax->list #'(path-rest ...))))))
|
|
#`(begin0 (dot-helper #,path #,field))))))
|
|
|
|
(define-syntax (open-as stx)
|
|
(syntax-case stx ()
|
|
((_ rename top-name path1 path-rest ...)
|
|
(let-values (((path field)
|
|
(split (cons #'top-name (cons #'path1 (syntax->list #'(path-rest ...)))))))
|
|
(unless (identifier? #'rename)
|
|
(raise-syntax-error 'open-as "First position must be an identifier" #'rename))
|
|
#`(define-syntaxes-ml (rename)
|
|
(open-as-helper #'#,path #'#,field))))))
|
|
)
|