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

toplevel can refer to module variables

Browse Source
This commit is contained in:
Danny Yoo 2011-03-26 17:23:51 -04:00
parent 6cb062d83e
commit b51922310c
9 changed files with 68 additions and 32 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

33
assemble.rkt
View File

@ -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)
",")))]

2
compile.rkt
View File

@ -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))))

2
il-structs.rkt
View File

@ -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

21
lexical-env.rkt
View File

@ -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))))

6
lexical-structs.rkt
View File

@ -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)

15
parse.rkt
View File

@ -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

5
simulator-structs.rkt
View File

@ -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)

11
simulator.rkt
View File

@ -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)

5
test-conform.rkt
View File

@ -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)