diff --git a/compiler.rkt b/compiler.rkt index 18fab20..f0ba626 100644 --- a/compiler.rkt +++ b/compiler.rkt @@ -6,31 +6,17 @@ "compiler-structs.rkt" "kernel-primitives.rkt" "optimize-il.rkt" + "parameters.rkt" racket/match racket/bool racket/list) (provide (rename-out [-compile compile]) compile-general-procedure-call - current-warn-unimplemented-kernel-primitive append-instruction-sequences) - - -(: default-warn-unimplemented-kernel-primitive (Symbol -> Void)) -(define (default-warn-unimplemented-kernel-primitive id) - (printf "WARNING: Primitive Kernel Value ~s has not been implemented\n" - id)) - - -(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void))) -(define current-warn-unimplemented-kernel-primitive (make-parameter default-warn-unimplemented-kernel-primitive)) - - - - (: -compile (Expression Target Linkage -> (Listof Statement))) ;; Generates the instruction-sequence stream. ;; Note: the toplevel generates the lambda body streams at the head, and then the diff --git a/package.rkt b/package.rkt index 55a9290..992503c 100644 --- a/package.rkt +++ b/package.rkt @@ -29,9 +29,13 @@ -(define (package-anonymous source-code should-follow? op) +(define (package-anonymous source-code + #:should-follow? should-follow? + #:output-port op) (fprintf op "(function() {\n") - (package source-code should-follow? op) + (package source-code + #:should-follow? should-follow? + #:output-port op) (fprintf op " return invoke; })\n")) @@ -41,7 +45,9 @@ ;; Compile package for the given source program. should-follow? ;; indicates whether we should continue following module paths. -(define (package source-code should-follow? op) +(define (package source-code + #:should-follow? should-follow? + #:output-port op) (let ([source-code-op (open-output-bytes)]) (fprintf op "var invoke = (function(MACHINE, SUCCESS, FAIL, PARAMS) {") (follow-dependencies (cons bootstrap (list source-code)) @@ -79,7 +85,6 @@ [(hash-has-key? visited (first sources)) (loop (rest sources))] [else - (printf "visiting ~s\n" (first sources)) (hash-set! visited (first sources) #t) (let-values ([(ast stmts) (get-ast-and-statements (first sources))]) (assemble/write-invoke stmts op) diff --git a/parameters.rkt b/parameters.rkt index 2efeec3..001a837 100644 --- a/parameters.rkt +++ b/parameters.rkt @@ -1,23 +1,44 @@ -#lang racket/base +#lang typed/racket/base (require "expression-structs.rkt" racket/path) (provide current-defined-name current-module-path - current-root-path) + current-root-path + current-warn-unimplemented-kernel-primitive) -;(: current-defined-name (Parameterof (U Symbol LamPositionalName))) -(define current-defined-name (make-parameter 'unknown)) - - -;(: current-module-path (Parameterof (U False Path))) +(: current-module-path (Parameterof (U False Path))) (define current-module-path (make-parameter (build-path (current-directory) "anonymous-module.rkt"))) -;(: current-root-path (Parameterof Path)) +(: current-root-path (Parameterof Path)) (define current-root-path (make-parameter (normalize-path (current-directory)))) + + + +(: current-warn-unimplemented-kernel-primitive (Parameterof (Symbol -> Void))) +(define current-warn-unimplemented-kernel-primitive + (make-parameter + (lambda: ([id : Symbol]) + (printf "WARNING: Primitive Kernel Value ~s has not been implemented\n" + id)))) + + + + + + + + + +;;; These parameters below will probably go away soon. +;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;;; + +(: current-defined-name (Parameterof (U Symbol LamPositionalName))) +(define current-defined-name (make-parameter 'unknown)) + diff --git a/tests/test-browser-evaluate.rkt b/tests/test-browser-evaluate.rkt index f6eae64..bfcdba9 100644 --- a/tests/test-browser-evaluate.rkt +++ b/tests/test-browser-evaluate.rkt @@ -18,7 +18,9 @@ (newline op) (fprintf op "var innerInvoke = ") - (package-anonymous program should-follow? op) + (package-anonymous program + #:should-follow? should-follow? + #:output-port op) (fprintf op "();\n") (fprintf op #<