suzanne.soy/racket
1
0
Fork 0
Code Issues Pull Requests Actions Packages Projects Releases Wiki Activity

Add syntax property with static init-depend information to compound-unit/infer results

Browse Source
This commit is contained in:
Daniel Feltey 2015-08-25 17:01:04 -05:00 committed by Vincent St-Amour
parent ddb683e1f2
commit 9b7e1767dd
2 changed files with 43 additions and 23 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

17
racket/collects/racket/private/unit-compiletime.rkt
View File

@ -22,7 +22,8 @@
map-sig split-requires split-requires* apply-mac complete-exports complete-imports check-duplicate-subs
process-spec
make-relative-introducer
bind-at)
bind-at
build-init-depend-property)
(define-syntax (apply-mac stx)
(syntax-case stx ()
@ -594,3 +595,17 @@
sstx
(cons unbox-stx #'x)
sstx)]))))
;; This utility function returns a list of natural numbers for use as a syntax
;; property needed to support units in Typed Racket
(define (build-init-depend-property init-depends imports)
;; Typed Racket does not support tagged imports or exports
;; so drop the tags from init-depends and imports
(let ([id-sigs (map cdr init-depends)]
[import-sigs (map cdr imports)])
(let loop ([i 0] [imports import-sigs])
(cond
[(null? imports) '()]
[else (if (member (car imports) id-sigs free-identifier=?)
(cons i (loop (add1 i) (cdr imports)))
(loop (add1 i) (cdr imports)))]))))

49
racket/collects/racket/unit.rkt
View File

@ -1645,29 +1645,34 @@
(syntax->list #'((((sub-in-key sub-in-code) ...) ...) ...))))
)
(values
(quasisyntax/loc (error-syntax)
(let ([deps '()]
[sub-tmp sub-exp] ...)
check-sub-exp ...
(make-unit
'name
(vector-immutable
(cons 'import-name
(vector-immutable import-key ...))
...)
(vector-immutable
(cons 'export-name
(vector-immutable export-key ...))
...)
deps
(lambda ()
(let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))]
(syntax-property
(quasisyntax/loc (error-syntax)
(let ([deps '()]
[sub-tmp sub-exp] ...)
check-sub-exp ...
(make-unit
'name
(vector-immutable
(cons 'import-name
(vector-immutable import-key ...))
...)
(vector-immutable
(cons 'export-name
(vector-immutable export-key ...))
...)
deps
(lambda ()
(let-values ([(sub-tmp sub-export-table-tmp) ((unit-go sub-tmp))]
...)
(values (lambda (import-table-id)
(void)
(sub-tmp (equal-hash-table sub-in-key-code-workaround ...))
...)
(values (lambda (import-table-id)
(void)
(sub-tmp (equal-hash-table sub-in-key-code-workaround ...))
...)
(unit-export ((export-key ...) export-code) ...)))))))
(unit-export ((export-key ...) export-code) ...)))))))
'tr:inferred-init-depend-property
(build-init-depend-property
static-dep-info
(map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))))
(map syntax-e (syntax->list #'((import-tag . import-sigid) ...)))
(map syntax-e (syntax->list #'((export-tag . export-sigid) ...)))
static-dep-info))))))