diff --git a/assemble.rkt b/assemble.rkt index 11e37e7..59a06b8 100644 --- a/assemble.rkt +++ b/assemble.rkt @@ -415,24 +415,31 @@ EOF [(CheckClosureArity!? op) (format "if (! (MACHINE.proc instanceof Closure && MACHINE.proc.arity === ~a)) { if (! (MACHINE.proc instanceof Closure)) { throw new Error(\"not a closure\"); } else { throw new Error(\"arity failure\"); } }" - (CheckClosureArity!-arity op) - )] + (CheckClosureArity!-arity op))] [(ExtendEnvironment/Prefix!? op) - (let: ([names : (Listof (U Symbol False)) (ExtendEnvironment/Prefix!-names op)]) + (let: ([names : (Listof (U Symbol False ModuleVariable)) (ExtendEnvironment/Prefix!-names op)]) (format "MACHINE.env.push([~a]); MACHINE.env[MACHINE.env.length-1].names = [~a];" - (string-join (map (lambda: ([n : (U Symbol False)]) - (if (symbol? n) - (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" - (symbol->string n) - (symbol->string n)) - "false")) + (string-join (map (lambda: ([n : (U Symbol False ModuleVariable)]) + (cond [(symbol? n) + (format "MACHINE.params.currentNamespace[~s] || Primitives[~s]" + (symbol->string n) + (symbol->string n))] + [(eq? n #f) + "false"] + [(ModuleVariable? n) + (format "Primitives[~s]" + (symbol->string (ModuleVariable-name n)))])) names) ",") - (string-join (map (lambda: ([n : (U Symbol False)]) - (if (symbol? n) - (format "~s" (symbol->string n)) - "false")) + (string-join (map (lambda: ([n : (U Symbol False ModuleVariable)]) + (cond + [(symbol? n) + (format "~s" (symbol->string n))] + [(eq? n #f) + "false"] + [(ModuleVariable? n) + (format "~s" (symbol->string (ModuleVariable-name n)))])) names) ",")))] diff --git a/compile.rkt b/compile.rkt index 8a8bf12..90f1dd2 100644 --- a/compile.rkt +++ b/compile.rkt @@ -161,7 +161,7 @@ (: compile-top (Top CompileTimeEnvironment Target Linkage -> InstructionSequence)) (define (compile-top top cenv target linkage) - (let*: ([names : (Listof (U Symbol False)) (Prefix-names (Top-prefix top))]) + (let*: ([names : (Listof (U Symbol ModuleVariable False)) (Prefix-names (Top-prefix top))]) (append-instruction-sequences (make-instruction-sequence `(,(make-PerformStatement (make-ExtendEnvironment/Prefix! names)))) diff --git a/il-structs.rkt b/il-structs.rkt index 857e03f..5eb251d 100644 --- a/il-structs.rkt +++ b/il-structs.rkt @@ -187,7 +187,7 @@ ;; Extends the environment with a prefix that holds ;; lookups to the namespace. -(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U Symbol False))]) +(define-struct: ExtendEnvironment/Prefix! ([names : (Listof (U Symbol ModuleVariable False))]) #:transparent) ;; Adjusts the environment by pushing the values in the diff --git a/lexical-env.rkt b/lexical-env.rkt index 6b26c4b..dbb714a 100644 --- a/lexical-env.rkt +++ b/lexical-env.rkt @@ -20,13 +20,16 @@ ;; Find where the variable is located in the lexical environment (: find-variable (Symbol ParseTimeEnvironment -> LexicalAddress)) (define (find-variable name cenv) - (: find-pos (Symbol (Listof (U Symbol False)) -> Natural)) + (: find-pos (Symbol (Listof (U Symbol ModuleVariable False)) -> Natural)) (define (find-pos sym los) - (cond - [(eq? sym (car los)) - 0] - [else - (add1 (find-pos sym (cdr los)))])) + (let ([elt (car los)]) + (cond + [(and (symbol? elt) (eq? sym elt)) + 0] + [(and (ModuleVariable? elt) (eq? (ModuleVariable-name elt) sym)) + 0] + [else + (add1 (find-pos sym (cdr los)))]))) (let: loop : LexicalAddress ([cenv : ParseTimeEnvironment cenv] [depth : Natural 0]) @@ -167,11 +170,15 @@ ;; Masks elements of the prefix off. (define (place-prefix-mask a-prefix symbols-to-keep) (make-Prefix - (map (lambda: ([n : (U Symbol False)]) + (map (lambda: ([n : (U Symbol False ModuleVariable)]) (cond [(symbol? n) (if (member n symbols-to-keep) n #f)] + [(ModuleVariable? n) + (if (member (ModuleVariable-name n) symbols-to-keep) + n + #f)] [else n])) (Prefix-names a-prefix)))) diff --git a/lexical-structs.rkt b/lexical-structs.rkt index 66b8f78..c63549b 100644 --- a/lexical-structs.rkt +++ b/lexical-structs.rkt @@ -9,7 +9,11 @@ ;; A toplevel prefix contains a list of toplevel variables. Some of the ;; names may be masked out by #f. -(define-struct: Prefix ([names : (Listof (U Symbol False))]) +(define-struct: Prefix ([names : (Listof (U Symbol ModuleVariable False))]) + #:transparent) + +(define-struct: ModuleVariable ([name : Symbol] + [module-path : 'kernel]) #:transparent) diff --git a/parse.rkt b/parse.rkt index 9ed255c..0fe6a2a 100644 --- a/parse.rkt +++ b/parse.rkt @@ -17,6 +17,21 @@ (make-Top prefix (parse exp (extend-lexical-environment '() prefix))))) +;; a language maps identifiers to module variables. +(define current-language (make-parameter '(+))) +;; lookup-in-current-language: symbol -> (or ModuleVariable #f) +(define (lookup-in-current-language sym) + (cond + [(current-language) + => (lambda (lang) + (if (member sym (lang)) + (make-ModuleVariable sym '#%kernel) + #f))] + [else + #f])) + + + ;; find-prefix: ParseTimeEnvironment -> Natural (define (find-prefix cenv) (cond diff --git a/simulator-structs.rkt b/simulator-structs.rkt index 08aebc6..e52e1d4 100644 --- a/simulator-structs.rkt +++ b/simulator-structs.rkt @@ -2,7 +2,8 @@ (provide (all-defined-out)) -(require "il-structs.rkt") +(require "il-structs.rkt" + "lexical-structs.rkt") (define-type PrimitiveValue (Rec PrimitiveValue (U String Number Symbol Boolean @@ -57,7 +58,7 @@ ) #:transparent) -(define-struct: toplevel ([names : (Listof (U #f Symbol))] +(define-struct: toplevel ([names : (Listof (U #f Symbol ModuleVariable))] [vals : (Listof PrimitiveValue)]) #:transparent #:mutable) diff --git a/simulator.rkt b/simulator.rkt index 40adcaa..277eab1 100644 --- a/simulator.rkt +++ b/simulator.rkt @@ -217,10 +217,13 @@ [(ExtendEnvironment/Prefix!? op) (env-push! m (make-toplevel (ExtendEnvironment/Prefix!-names op) - (map (lambda: ([id/false : (U Symbol False)]) - (if (symbol? id/false) - (lookup-primitive id/false) - #f)) + (map (lambda: ([name : (U Symbol ModuleVariable False)]) + (cond [(symbol? name) + (lookup-primitive name)] + [(ModuleVariable? name) + (lookup-primitive (ModuleVariable-name name))] + [(eq? name #f) + (make-undefined)])) (ExtendEnvironment/Prefix!-names op))))] [(InstallClosureValues!? op) diff --git a/test-conform.rkt b/test-conform.rkt index 5ee9978..0ba218d 100644 --- a/test-conform.rkt +++ b/test-conform.rkt @@ -64,8 +64,7 @@ #'stx)) (printf "ok. ~s steps.\n\n" num-steps)))))])) -(current-simulated-output-port (current-output-port)) (test (read (open-input-file "tests/conform/program0.sch")) - (port->string (open-input-file "tests/conform/expected0.txt")) - #:debug? #f) + (port->string (open-input-file "tests/conform/expected0.txt")) + #:debug? #f)