diff --git a/compiler.rkt b/compiler.rkt index 35add10..a9e01f3 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -147,7 +147,9 @@ [(PrimitiveKernelValue? exp) '()] [(VariableReference? exp) - (loop (VariableReference-toplevel exp) cenv)]))) + (loop (VariableReference-toplevel exp) cenv)] + [(Require? exp) + '()]))) @@ -270,7 +272,9 @@ [(PrimitiveKernelValue? exp) (compile-primitive-kernel-value exp cenv target linkage)] [(VariableReference? exp) - (compile-variable-reference exp cenv target linkage)])) + (compile-variable-reference exp cenv target linkage)] + [(Require? exp) + (compile-require exp cenv target linkage)])) @@ -339,6 +343,14 @@ after-module-body)))) +(: compile-require (Require CompileTimeEnvironment Target Linkage -> InstructionSequence)) +(define (compile-require exp cenv target linkage) + (end-with-linkage linkage cenv + (append-instruction-sequences + (compile-module-invoke (Require-path exp)) + (make-instruction-sequence + `(,(make-AssignImmediateStatement target (make-Const (void)))))))) + (: compile-module-invoke (ModuleName -> InstructionSequence)) ;; Generates code that will invoke a module (if it hasn't been invoked yet) @@ -357,8 +369,9 @@ ;; TODO: raise an exception here that says that the module hasn't been ;; linked yet. ,(make-DebugPrint (make-Const - (format "DEBUG: the module ~a hasn't been linked in yet!" + (format "DEBUG: the module ~a hasn't been linked in!!!" (ModuleName-name a-module-name)))) + ,(make-GotoStatement (make-Label already-loaded)) ,linked ,(make-TestAndBranchStatement (make-TestTrue (make-IsModuleInvoked a-module-name)) @@ -2233,4 +2246,6 @@ [(VariableReference? exp) (make-VariableReference (ensure-toplevelref - (adjust-expression-depth (VariableReference-toplevel exp) n skip)))])) \ No newline at end of file + (adjust-expression-depth (VariableReference-toplevel exp) n skip)))] + [(Require? exp) + exp])) \ No newline at end of file diff --git a/expression-structs.rkt b/expression-structs.rkt index 5d1b78e..a78ba2d 100644 --- a/expression-structs.rkt +++ b/expression-structs.rkt @@ -29,7 +29,9 @@ DefValues PrimitiveKernelValue Module - VariableReference)) + VariableReference + Require)) + (define-struct: Provided ([name : Symbol] @@ -87,7 +89,7 @@ ;; We may have more information about the lambda's name. This will show it. (define-struct: LamPositionalName ([name : Symbol] - [path : String] + [path : String] ;; the source of the name [line : Natural] [column : Natural] [offset : Natural] @@ -147,7 +149,7 @@ (define-struct: VariableReference ([toplevel : ToplevelRef]) #:transparent) - +(define-struct: Require ([path : ModuleName]) #:transparent) diff --git a/lexical-structs.rkt b/lexical-structs.rkt index 9bd6b07..bfce6c9 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -17,7 +17,8 @@ ;; A ModuleName is an identifier for a Module. -(define-struct: ModuleName ([name : Symbol]) +(define-struct: ModuleName ([name : Symbol] + [real-path : (U Symbol Path)]) #:transparent) diff --git a/parse-bytecode-5.1.1.rkt b/parse-bytecode-5.1.1.rkt index 50b1315..9ec38a8 100644 --- a/parse-bytecode-5.1.1.rkt +++ b/parse-bytecode-5.1.1.rkt @@ -7,13 +7,16 @@ syntax/modresolve) -;; Parsing Racket 5.1.1 bytecode structures into our own. +;; Parsing Racket 5.1.1 bytecode structures into our own structures. + (require compiler/zo-parse racket/match racket/list) + (provide parse-bytecode - current-module-path-index-resolver + ;current-module-path-index-resolver + ;current-module-path-resolver current-module-path reset-lam-label-counter!/unit-testing) @@ -33,6 +36,13 @@ (resolve-module-path-index mpi relative-to)])))) +(define current-module-path-resolver + (make-parameter + (lambda (module-path relative-to) + (resolve-module-path module-path relative-to)))) + + + (define (self-module-path-index? mpi) (let-values ([(x y) (module-path-index-split mpi)]) (and (eq? x #f) @@ -150,9 +160,16 @@ (define (wrap-module-name resolved-path-name) (cond [(symbol? resolved-path-name) - (make-ModuleName resolved-path-name)] + (make-ModuleName resolved-path-name resolved-path-name)] [(path? resolved-path-name) - (make-ModuleName (rewrite-path resolved-path-name))])) + (let ([rewritten-path (rewrite-path resolved-path-name)]) + (cond + [(symbol? rewritten-path) + (make-ModuleName (rewrite-path resolved-path-name) resolved-path-name)] + [else + (error 'wrap-module-name "Unable to resolve module path ~s" resolved-path-name)]))])) + + @@ -199,8 +216,53 @@ (make-Constant (void))) + (define (parse-req form) - (error 'fixme-req)) + (let ([resolver (current-module-path-resolver)]) + (match form + [(struct req (reqs dummy)) + (let ([require-statement (parse-req-reqs reqs)]) + (match require-statement + [(list '#%require (and (? module-path?) path)) + (let ([resolved-path ((current-module-path-resolver) path (current-module-path))]) + (cond + [(symbol? resolved-path) + (make-Require (make-ModuleName resolved-path resolved-path))] + [(path? resolved-path) + (let ([rewritten-path (rewrite-path resolved-path)]) + (cond + [(symbol? rewritten-path) + (make-Require (make-ModuleName rewritten-path resolved-path))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))] + [else + (printf "Internal error: I don't know how to handle the require for ~s" require-statement) + (error 'parse-req)]))]))) + +;; parse-req-reqs: (stx -> (listof ModuleName)) +(define (parse-req-reqs reqs) + (match reqs + [(struct stx (encoded)) + (unwrap-wrapped encoded)])) + +(define (unwrap-wrapped encoded) + (cond [(wrapped? encoded) + (match encoded + [(struct wrapped (datum wraps certs)) + (unwrap-wrapped datum)])] + [(pair? encoded) + (cons (unwrap-wrapped (car encoded)) + (unwrap-wrapped (cdr encoded)))] + [(null? encoded) + null] + [else + encoded])) + + ;; parse-seq: seq -> Expression @@ -209,6 +271,7 @@ [(struct seq (forms)) (make-Seq (map parse-form-item forms))])) + ;; parse-form-item: (U form Any) -> Expression (define (parse-form-item item) (cond @@ -247,18 +310,23 @@ (cond [(symbol? self-path) (make-Module name - (make-ModuleName self-path) + (make-ModuleName self-path self-path) (parse-prefix prefix) (parse-mod-requires self-modidx requires) (parse-mod-provides provides) (parse-mod-body body))] [else - (make-Module name - (make-ModuleName (rewrite-path self-path)) - (parse-prefix prefix) - (parse-mod-requires self-modidx requires) - (parse-mod-provides provides) - (parse-mod-body body))]))])) + (let ([rewritten-path (rewrite-path self-path)]) + (cond + [(symbol? rewritten-path) + (make-Module name + (make-ModuleName rewritten-path self-path) + (parse-prefix prefix) + (parse-mod-requires self-modidx requires) + (parse-mod-provides provides) + (parse-mod-body body))] + [else + (error 'parse-mod "Internal error: unable to resolve module path ~s" self-path)]))]))])) ;; parse-mod-requires: module-path-index (listof (pair (U Integer #f) (listof module-path-index))) -> (listof ModuleName) @@ -411,14 +479,30 @@ [(vector? name) (match name [(vector (and (? symbol?) sym) - (and (? path?) path) + (and (? path?) source) + (and (? number?) line) + (and (? number?) column) + (and (? number?) offset) + (and (? number?) span) + _) + (let ([try-to-rewrite (rewrite-path source)]) + (make-LamPositionalName sym + (if try-to-rewrite + (symbol->string try-to-rewrite) + (path->string source)) + line + column + offset + span))] + [(vector (and (? symbol?) sym) + (and (? symbol?) source) (and (? number?) line) (and (? number?) column) (and (? number?) offset) (and (? number?) span) _) (make-LamPositionalName sym - (path->string path) + (symbol->string source) line column offset @@ -509,6 +593,8 @@ (define (parse-topsyntax expr) + ;; We should not get into this because we're only parsing the runtime part of + ;; the bytecode. (error 'fixme-topsyntax)) diff --git a/parse.rkt b/parse.rkt index e6827c4..bdf0318 100644 --- a/parse.rkt +++ b/parse.rkt @@ -52,7 +52,7 @@ [(current-language) => (lambda (lang) (if (member sym lang) - (make-ModuleVariable sym (make-ModuleName '#%kernel)) + (make-ModuleVariable sym (make-ModuleName '#%kernel '#%kernel)) #f))] [else #f])) diff --git a/path-rewriter.rkt b/path-rewriter.rkt index 48c2239..165d27a 100644 --- a/path-rewriter.rkt +++ b/path-rewriter.rkt @@ -26,18 +26,14 @@ ;; The path rewriter takes paths and provides a canonical symbol for it. -;; Paths located within collects get remapped to collects/.... - +;; Paths located within collects get remapped to collects, those within +;; the compiler directory mapped to "js-vm", those within the root to "root". +;; If none of these work, we return #f. ;; rewrite-path: path -> (symbol #f) (define (rewrite-path a-path) (let ([a-path (normalize-path a-path)]) (cond - [(within-root? a-path) - (string->symbol - (string-append "root/" - (path->string - (find-relative-path (current-root-path) a-path))))] [(within-collects? a-path) (string->symbol (string-append "collects/" @@ -48,6 +44,11 @@ (string-append "js-vm/" (path->string (find-relative-path this-normal-path a-path))))] + [(within-root? a-path) + (string->symbol + (string-append "root/" + (path->string + (find-relative-path (current-root-path) a-path))))] [else #f]))) diff --git a/test-parse-bytecode-5.1.1.rkt b/test-parse-bytecode-5.1.1.rkt index 842e311..517bffe 100644 --- a/test-parse-bytecode-5.1.1.rkt +++ b/test-parse-bytecode-5.1.1.rkt @@ -377,21 +377,18 @@ (run-my-parse #'(case-lambda [(x) x] [(x y) (list x y)]))) - -;; make sure we don't see an infinite loop -#;(run-zo-parse #'(letrec ([g (lambda () (g))]) - (g))) -(run-my-parse #'(letrec ([g (lambda () (g))]) - (g))) -;; todo: add tests to make sure we're parsing this as expected. We expect to see an EmptyClosureReference here. +(void + (run-my-parse #'(letrec ([g (lambda () (g))]) + (g)))) -#;(run-zo-parse #'(letrec ([g (lambda () (h))] - [h (lambda () (g))]) - (g))) -;; FIXME: we need to handle closure cycles here. +(void + (run-my-parse #'(letrec ([g (case-lambda [() (g)] + [(x y) (g x y)])]) + (g)))) + diff --git a/test-parse.rkt b/test-parse.rkt index cae06bc..689b59a 100644 --- a/test-parse.rkt +++ b/test-parse.rkt @@ -208,7 +208,7 @@ 'lamEntry2))) (test (parse '(+ x x)) - (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel)) + (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel)) x)) (make-App (make-ToplevelRef 2 0) (list (make-ToplevelRef 2 1) @@ -216,7 +216,7 @@ (test (parse '(lambda (x) (+ x x))) - (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel)))) + (make-Top (make-Prefix `(,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel)))) (make-Lam 'unknown 1 #f (make-App (make-ToplevelRef 2 0) (list (make-LocalRef 3 #f) @@ -226,8 +226,8 @@ (test (parse '(lambda (x) (+ (* x x) x))) - (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel)) - ,(make-ModuleVariable '+ (make-ModuleName '#%kernel)))) + (make-Top (make-Prefix `(,(make-ModuleVariable '* (make-ModuleName '#%kernel '#%kernel)) + ,(make-ModuleVariable '+ (make-ModuleName '#%kernel '#%kernel)))) (make-Lam 'unknown 1 #f ;; stack layout: [???, ???, prefix, x] (make-App (make-ToplevelRef 2 1) @@ -286,7 +286,7 @@ (test (parse '(let* ([x 3] [x (add1 x)]) (add1 x))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel)))) ;; stack layout: [prefix] @@ -415,7 +415,7 @@ (test (parse '(let ([x 0]) (lambda () (set! x (add1 x))))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel)))) (make-Let1 (make-Constant 0) (make-BoxEnv 0 (make-Lam 'unknown 0 #f @@ -434,7 +434,7 @@ [y 1]) (lambda () (set! x (add1 x))))) - (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel)))) + (make-Top (make-Prefix `(,(make-ModuleVariable 'add1 (make-ModuleName '#%kernel '#%kernel)))) (make-LetVoid 2 (make-Seq (list (make-InstallValue 1 0 (make-Constant 0) #t) @@ -462,7 +462,7 @@ (reset!) (list a b))) (make-Top - (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel)) reset!)) + (make-Prefix `(a b ,(make-ModuleVariable 'list (make-ModuleName '#%kernel '#%kernel)) reset!)) (make-Splice (list (make-ToplevelSet 0 0 (make-Constant '(hello)))