Small change so that failures due to the implicit compound-unit/infer (like
init-depend failures) will show define-values/invoke-unit/infer as the original source of the problem. svn: r15780
This commit is contained in:
Stevie Strickland
parent
3c6f5e5c98
commit
7d551aa0f2
|
|
@ -1502,127 +1502,6 @@
|
|||
#`(tag #,(car ti) #,(cdr ti))
|
||||
(cdr ti)))
|
||||
|
||||
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
|
||||
(define-for-syntax (build-invoke-unit/infer units define? exports)
|
||||
(define (imps/exps-from-unit u)
|
||||
(let* ([ui (lookup-def-unit u)]
|
||||
[unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
|
||||
(lambda (p)
|
||||
(unprocess-tagged-id (cons (car p) (i (cdr p))))))]
|
||||
[isigs (map unprocess (unit-info-import-sig-ids ui))]
|
||||
[esigs (map unprocess (unit-info-export-sig-ids ui))])
|
||||
(values isigs esigs)))
|
||||
(define (drop-from-other-list exp-tagged imp-tagged imp-sources)
|
||||
(let loop ([ts imp-tagged] [ss imp-sources])
|
||||
(cond
|
||||
[(null? ts) null]
|
||||
[(ormap (lambda (tinfo2)
|
||||
(and (eq? (car (car ts)) (car tinfo2))
|
||||
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
|
||||
exp-tagged)
|
||||
(loop (cdr ts) (cdr ss))]
|
||||
[else (cons (car ss) (loop (cdr ts) (cdr ss)))])))
|
||||
|
||||
(define (drop-duplicates tagged-siginfos sources)
|
||||
(let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null])
|
||||
(cond
|
||||
[(null? ts) (values res-t res-s)]
|
||||
[(ormap (lambda (tinfo2)
|
||||
(and (eq? (car (car ts)) (car tinfo2))
|
||||
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
|
||||
(cdr ts))
|
||||
(loop (cdr ts) (cdr ss) res-t res-s)]
|
||||
[else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))])))
|
||||
|
||||
(define (imps/exps-from-units units exports)
|
||||
(define-values (isigs esigs)
|
||||
(let loop ([units units] [imps null] [exps null])
|
||||
(if (null? units)
|
||||
(values imps exps)
|
||||
(let-values ([(i e) (imps/exps-from-unit (car units))])
|
||||
(loop (cdr units) (append i imps) (append e exps))))))
|
||||
(define-values (isig tagged-import-sigs import-tagged-infos
|
||||
import-tagged-sigids import-sigs)
|
||||
(process-unit-import (datum->syntax-object #f isigs)))
|
||||
|
||||
(define-values (esig tagged-export-sigs export-tagged-infos
|
||||
export-tagged-sigids export-sigs)
|
||||
(process-unit-export (datum->syntax-object #f esigs)))
|
||||
(check-duplicate-subs export-tagged-infos esig)
|
||||
(let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
|
||||
(values (drop-from-other-list export-tagged-infos itagged isources)
|
||||
(cond
|
||||
[(list? exports)
|
||||
(let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos
|
||||
spec-export-tagged-sigids spec-export-sigs)
|
||||
(process-unit-export (datum->syntax-object #f exports))])
|
||||
(restrict-exports export-tagged-infos
|
||||
spec-esig spec-export-tagged-infos))]
|
||||
[else esig]))))
|
||||
|
||||
(define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports)
|
||||
(for-each (lambda (se ste)
|
||||
(unless (ormap (lambda (ute)
|
||||
(and (eq? (car ute) (car ste))
|
||||
(siginfo-subtype (cdr ute) (cdr ste))))
|
||||
unit-tagged-exports)
|
||||
(raise-stx-err (format "no subunit exports signature ~a"
|
||||
(syntax-object->datum se))
|
||||
se)))
|
||||
spec-exports
|
||||
spec-tagged-exports)
|
||||
spec-exports)
|
||||
(when (and (not define?) exports)
|
||||
(error 'build-invoke-unit/infer
|
||||
"internal error: exports for invoke-unit/infer"))
|
||||
(when (null? units)
|
||||
(raise-stx-err "no units in link clause"))
|
||||
(cond [(identifier? units)
|
||||
(let-values ([(isig esig) (imps/exps-from-units (list units) exports)])
|
||||
(with-syntax ([u units]
|
||||
[(esig ...) esig]
|
||||
[(isig ...) isig])
|
||||
(if define?
|
||||
(syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))]
|
||||
[(list? units)
|
||||
(let-values ([(isig esig) (imps/exps-from-units units exports)])
|
||||
(with-syntax ([(new-unit) (generate-temporaries '(new-unit))]
|
||||
[(unit ...) units]
|
||||
[(esig ...) esig]
|
||||
[(isig ...) isig])
|
||||
(with-syntax ([cunit (syntax/loc (error-syntax)
|
||||
(define-compound-unit/infer new-unit
|
||||
(import isig ...) (export esig ...) (link unit ...)))])
|
||||
|
||||
(if define?
|
||||
(syntax/loc (error-syntax)
|
||||
(begin cunit
|
||||
(define-values/invoke-unit new-unit (import isig ...) (export esig ...))))
|
||||
(syntax/loc (error-syntax)
|
||||
(let ()
|
||||
cunit
|
||||
(invoke-unit new-unit (import isig ...))))))))]
|
||||
;; just for error handling
|
||||
[else (lookup-def-unit units)]))
|
||||
|
||||
(define-syntax/err-param (define-values/invoke-unit/infer stx)
|
||||
(syntax-case stx (export link)
|
||||
[(_ (link unit ...))
|
||||
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)]
|
||||
[(_ (export e ...) (link unit ...))
|
||||
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))]
|
||||
[(_ (export e ...) u)
|
||||
(build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))]
|
||||
[(_ u)
|
||||
(build-invoke-unit/infer #'u #t #f)]
|
||||
[(_)
|
||||
(raise-stx-err "missing unit" stx)]
|
||||
[(_ . b)
|
||||
(raise-stx-err
|
||||
(format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
|
||||
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
|
||||
|
||||
(define-for-syntax (temp-id-with-tags id i)
|
||||
(syntax-case i (tag)
|
||||
[(tag t sig)
|
||||
|
|
@ -1852,6 +1731,128 @@
|
|||
(define-syntax/err-param (define-compound-unit/infer stx)
|
||||
(do-define-compound-unit/infer stx))
|
||||
|
||||
;; (syntax or listof[syntax]) boolean (boolean or listof[syntax]) -> syntax
|
||||
(define-for-syntax (build-invoke-unit/infer units define? exports)
|
||||
(define (imps/exps-from-unit u)
|
||||
(let* ([ui (lookup-def-unit u)]
|
||||
[unprocess (let ([i (make-syntax-delta-introducer u (unit-info-orig-binder ui))])
|
||||
(lambda (p)
|
||||
(unprocess-tagged-id (cons (car p) (i (cdr p))))))]
|
||||
[isigs (map unprocess (unit-info-import-sig-ids ui))]
|
||||
[esigs (map unprocess (unit-info-export-sig-ids ui))])
|
||||
(values isigs esigs)))
|
||||
(define (drop-from-other-list exp-tagged imp-tagged imp-sources)
|
||||
(let loop ([ts imp-tagged] [ss imp-sources])
|
||||
(cond
|
||||
[(null? ts) null]
|
||||
[(ormap (lambda (tinfo2)
|
||||
(and (eq? (car (car ts)) (car tinfo2))
|
||||
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
|
||||
exp-tagged)
|
||||
(loop (cdr ts) (cdr ss))]
|
||||
[else (cons (car ss) (loop (cdr ts) (cdr ss)))])))
|
||||
|
||||
(define (drop-duplicates tagged-siginfos sources)
|
||||
(let loop ([ts tagged-siginfos] [ss sources] [res-t null] [res-s null])
|
||||
(cond
|
||||
[(null? ts) (values res-t res-s)]
|
||||
[(ormap (lambda (tinfo2)
|
||||
(and (eq? (car (car ts)) (car tinfo2))
|
||||
(siginfo-subtype (cdr tinfo2) (cdr (car ts)))))
|
||||
(cdr ts))
|
||||
(loop (cdr ts) (cdr ss) res-t res-s)]
|
||||
[else (loop (cdr ts) (cdr ss) (cons (car ts) res-t) (cons (car ss) res-s))])))
|
||||
|
||||
(define (imps/exps-from-units units exports)
|
||||
(define-values (isigs esigs)
|
||||
(let loop ([units units] [imps null] [exps null])
|
||||
(if (null? units)
|
||||
(values imps exps)
|
||||
(let-values ([(i e) (imps/exps-from-unit (car units))])
|
||||
(loop (cdr units) (append i imps) (append e exps))))))
|
||||
(define-values (isig tagged-import-sigs import-tagged-infos
|
||||
import-tagged-sigids import-sigs)
|
||||
(process-unit-import (datum->syntax-object #f isigs)))
|
||||
|
||||
(define-values (esig tagged-export-sigs export-tagged-infos
|
||||
export-tagged-sigids export-sigs)
|
||||
(process-unit-export (datum->syntax-object #f esigs)))
|
||||
(check-duplicate-subs export-tagged-infos esig)
|
||||
(let-values ([(itagged isources) (drop-duplicates import-tagged-infos isig)])
|
||||
(values (drop-from-other-list export-tagged-infos itagged isources)
|
||||
(cond
|
||||
[(list? exports)
|
||||
(let-values ([(spec-esig spec-tagged-export-sigs spec-export-tagged-infos
|
||||
spec-export-tagged-sigids spec-export-sigs)
|
||||
(process-unit-export (datum->syntax-object #f exports))])
|
||||
(restrict-exports export-tagged-infos
|
||||
spec-esig spec-export-tagged-infos))]
|
||||
[else esig]))))
|
||||
|
||||
(define (restrict-exports unit-tagged-exports spec-exports spec-tagged-exports)
|
||||
(for-each (lambda (se ste)
|
||||
(unless (ormap (lambda (ute)
|
||||
(and (eq? (car ute) (car ste))
|
||||
(siginfo-subtype (cdr ute) (cdr ste))))
|
||||
unit-tagged-exports)
|
||||
(raise-stx-err (format "no subunit exports signature ~a"
|
||||
(syntax-object->datum se))
|
||||
se)))
|
||||
spec-exports
|
||||
spec-tagged-exports)
|
||||
spec-exports)
|
||||
(when (and (not define?) exports)
|
||||
(error 'build-invoke-unit/infer
|
||||
"internal error: exports for invoke-unit/infer"))
|
||||
(when (null? units)
|
||||
(raise-stx-err "no units in link clause"))
|
||||
(cond [(identifier? units)
|
||||
(let-values ([(isig esig) (imps/exps-from-units (list units) exports)])
|
||||
(with-syntax ([u units]
|
||||
[(esig ...) esig]
|
||||
[(isig ...) isig])
|
||||
(if define?
|
||||
(syntax/loc (error-syntax) (define-values/invoke-unit u (import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax) (invoke-unit u (import isig ...))))))]
|
||||
[(list? units)
|
||||
(let-values ([(isig esig) (imps/exps-from-units units exports)])
|
||||
(with-syntax ([(new-unit) (generate-temporaries '(new-unit))]
|
||||
[(unit ...) units]
|
||||
[(esig ...) esig]
|
||||
[(isig ...) isig])
|
||||
(with-syntax ([u (let-values ([(u i e d)
|
||||
(build-compound-unit/infer
|
||||
(check-compound/infer-syntax
|
||||
#'((import isig ...)
|
||||
(export esig ...)
|
||||
(link unit ...))))]) u)])
|
||||
(if define?
|
||||
(syntax/loc (error-syntax)
|
||||
(define-values/invoke-unit u
|
||||
(import isig ...) (export esig ...)))
|
||||
(syntax/loc (error-syntax)
|
||||
(invoke-unit u
|
||||
(import isig ...)))))))]
|
||||
;; just for error handling
|
||||
[else (lookup-def-unit units)]))
|
||||
|
||||
(define-syntax/err-param (define-values/invoke-unit/infer stx)
|
||||
(syntax-case stx (export link)
|
||||
[(_ (link unit ...))
|
||||
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t #f)]
|
||||
[(_ (export e ...) (link unit ...))
|
||||
(build-invoke-unit/infer (syntax->list #'(unit ...)) #t (syntax->list #'(e ...)))]
|
||||
[(_ (export e ...) u)
|
||||
(build-invoke-unit/infer #'u #t (syntax->list #'(e ...)))]
|
||||
[(_ u)
|
||||
(build-invoke-unit/infer #'u #t #f)]
|
||||
[(_)
|
||||
(raise-stx-err "missing unit" stx)]
|
||||
[(_ . b)
|
||||
(raise-stx-err
|
||||
(format "expected syntax matching (~a [(export <define-signature-identifier>)] <define-unit-identifier>) or (~a [(export <define-signature-identifier>)] (link <define-unit-identifier> ...))"
|
||||
(syntax-e (stx-car stx)) (syntax-e (stx-car stx))))]))
|
||||
|
||||
(define-syntax/err-param (invoke-unit stx)
|
||||
(syntax-case stx (import)
|
||||
((_ unit)
|
||||
|
|
|
|||
|
|
@ -1368,17 +1368,33 @@
|
|||
(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
|
||||
(define-values/invoke-unit/infer (export y-sig) (link u v)))
|
||||
|
||||
(test-runtime-error exn? "unbound variable: x"
|
||||
(test-runtime-error exn? "define-values/invoke-unit/infer: unbound variable: x"
|
||||
(let ()
|
||||
(define-values/invoke-unit/infer (export) (link u v))
|
||||
x))
|
||||
(test-syntax-error "define-values/invoke-unit/infer: doesn't export y"
|
||||
(define-values/invoke-unit/infer (export y-sig) v))
|
||||
(test-runtime-error exn? "unbound variable: x"
|
||||
(test-runtime-error exn? "define-values/invoke-unit/infer: unbound variable: x"
|
||||
(let ()
|
||||
(define-values/invoke-unit/infer (export) v)
|
||||
x))
|
||||
|
||||
(let ()
|
||||
(define-signature s^ (a))
|
||||
(define-signature t^ (b))
|
||||
(define-unit u@
|
||||
(import s^)
|
||||
(export t^)
|
||||
(init-depend s^)
|
||||
(define b a))
|
||||
(define-unit v@
|
||||
(import)
|
||||
(export s^)
|
||||
(define a 2))
|
||||
(define-values/invoke-unit/infer (export) (link v@ u@))
|
||||
(test-runtime-error exn? "define-values/invoke-unit/infer: init-depend broken"
|
||||
(define-values/invoke-unit/infer (export) (link u@ v@))))
|
||||
|
||||
|
||||
(define-unit u (import x-sig) (export) x)
|
||||
(test-syntax-error "define-values/invoke-unit/infer: bad imports"
|
||||
|
|
|
|||
Loading…
Reference in New Issue
Block a user