144 lines
5.0 KiB
Racket
144 lines
5.0 KiB
Racket
#lang typed/racket/base
|
|
|
|
(require "compiler/compiler.rkt"
|
|
"compiler/il-structs.rkt"
|
|
"compiler/lexical-structs.rkt"
|
|
"compiler/bootstrapped-primitives.rkt"
|
|
"compiler/compiler-structs.rkt"
|
|
"compiler/expression-structs.rkt"
|
|
"get-dependencies.rkt"
|
|
"parameters.rkt"
|
|
"sets.rkt"
|
|
"make-structs.rkt"
|
|
racket/list
|
|
racket/match)
|
|
|
|
|
|
(require/typed "parser/parse-bytecode.rkt"
|
|
[parse-bytecode (Any -> Expression)])
|
|
|
|
(require/typed "get-module-bytecode.rkt"
|
|
[get-module-bytecode ((U String Path Input-Port) -> Bytes)])
|
|
|
|
|
|
(provide make
|
|
get-ast-and-statements)
|
|
|
|
|
|
|
|
(: get-ast-and-statements (Source -> (values (U False Expression)
|
|
(Listof Statement))))
|
|
(define (get-ast-and-statements a-source)
|
|
(cond
|
|
[(StatementsSource? a-source)
|
|
(values #f (StatementsSource-stmts a-source))]
|
|
|
|
[(MainModuleSource? a-source)
|
|
(let-values ([(ast stmts)
|
|
(get-ast-and-statements (MainModuleSource-source a-source))])
|
|
(let ([maybe-module-locator (find-module-locator ast)])
|
|
(cond
|
|
[(ModuleLocator? maybe-module-locator)
|
|
(values ast (append stmts
|
|
;; Set the main module name
|
|
(list (make-PerformStatement
|
|
(make-AliasModuleName!
|
|
maybe-module-locator
|
|
(make-ModuleLocator '*main* '*main*))))))]
|
|
[else
|
|
(values ast stmts)])))]
|
|
|
|
[else
|
|
(let ([ast
|
|
(cond
|
|
[(ModuleSource? a-source)
|
|
(parse-bytecode (ModuleSource-path a-source))]
|
|
[(SexpSource? a-source)
|
|
(let ([source-code-op (open-output-bytes)])
|
|
(write (SexpSource-sexp a-source) source-code-op)
|
|
(parse-bytecode
|
|
(open-input-bytes
|
|
(get-module-bytecode
|
|
(open-input-bytes
|
|
(get-output-bytes source-code-op))))))])])
|
|
(values ast
|
|
(compile ast 'val next-linkage/drop-multiple)))]))
|
|
|
|
|
|
|
|
(: find-module-locator ((U Expression False) -> (U False ModuleLocator)))
|
|
;; Tries to look for the module locator of this expression.
|
|
(define (find-module-locator exp)
|
|
(match exp
|
|
[(struct Top ((? Prefix?)
|
|
(struct Module (name
|
|
(and path (? ModuleLocator?))
|
|
prefix
|
|
requires
|
|
code))))
|
|
path]
|
|
[else
|
|
#f]))
|
|
|
|
|
|
|
|
|
|
(: make ((Listof Source) Configuration -> Void))
|
|
(define (make sources config)
|
|
(parameterize ([current-seen-unimplemented-kernel-primitives
|
|
((inst new-seteq Symbol))])
|
|
|
|
(match config
|
|
[(struct Configuration (should-follow?
|
|
on-module-statements
|
|
after-module-statements
|
|
after-last))
|
|
|
|
|
|
(: follow-dependencies ((Listof Source) -> Void))
|
|
(define (follow-dependencies sources)
|
|
(define visited ((inst make-hash Any Boolean)))
|
|
|
|
(: collect-new-dependencies
|
|
((U False Expression) (Listof Source) -> (Listof Source)))
|
|
(define (collect-new-dependencies ast sources)
|
|
(cond
|
|
[(eq? ast #f)
|
|
sources]
|
|
[else
|
|
(let* ([dependent-module-names (get-dependencies ast)]
|
|
[paths
|
|
(foldl (lambda: ([mp : ModuleLocator]
|
|
[acc : (Listof Source)])
|
|
(let ([rp [ModuleLocator-real-path mp]])
|
|
|
|
(cond [((current-kernel-module-locator?)
|
|
mp)
|
|
acc]
|
|
[(and (path? rp)
|
|
(should-follow? rp)
|
|
(cons (make-ModuleSource rp)
|
|
acc))]
|
|
[else
|
|
acc])))
|
|
'()
|
|
dependent-module-names)])
|
|
(append paths sources))]))
|
|
|
|
(let: loop : Void ([sources : (Listof Source) sources])
|
|
(cond
|
|
[(empty? sources)
|
|
(after-last)]
|
|
[(hash-has-key? visited (first sources))
|
|
(loop (rest sources))]
|
|
[else
|
|
(hash-set! visited (first sources) #t)
|
|
(let-values ([(ast stmts)
|
|
(get-ast-and-statements (first sources))])
|
|
(on-module-statements ast stmts)
|
|
(loop (collect-new-dependencies ast (rest sources)))
|
|
(after-module-statements ast stmts))])))
|
|
|
|
(follow-dependencies sources)])))
|
|
|