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

modulevariables

Browse Source
This commit is contained in:
Danny Yoo 2011-05-25 22:11:34 -04:00
parent a92e6b95e4
commit 24e39ede45
6 changed files with 114 additions and 21 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

9
NOTES
View File

@ -565,4 +565,11 @@ Let me list out, roughly, what's left for me to do do:
I've isolated exactly what primitives I need to get racket/base up and
running. It looks like I need 231 of them. That's not that much,
actually. experiments/primitives-for-racket-base describes which ones
we need.
we need.
----------------------------------------------------------------------
May 25, 2011
About to make modules work. Need to make sure exports can rename names.

6
il-structs.rkt
View File

@ -430,6 +430,11 @@
[to : ModuleLocator])
#:transparent)
;; Given the module locator, do any finalizing operations, like
;; setting up the module namespace.
(define-struct: FinalizeModuleInvokation! ([path : ModuleLocator])
#:transparent)
(define-type PrimitiveCommand (U
@ -458,6 +463,7 @@
InstallModuleEntry!
MarkModuleInvoked!
AliasModuleName!
FinalizeModuleInvokation!
))

19
js-assembler/assemble-perform-statement.rkt
View File

@ -2,6 +2,7 @@
(require "assemble-helpers.rkt"
"../il-structs.rkt"
"../lexical-structs.rkt"
"../parameters.rkt"
racket/string)
(provide assemble-op-statement)
@ -46,8 +47,17 @@
;; FIXME: this should be looking at the module path and getting
;; the value here! It shouldn't be looking into Primitives...
[(ModuleVariable? n)
(format "MACHINE.primitives[~s]"
(symbol->string (ModuleVariable-name n)))]))
(cond
[((current-kernel-module-locator?)
(ModuleVariable-module-name n))
(format "MACHINE.primitives[~s]"
(symbol->string (ModuleVariable-name n)))]
[else
(format "MACHINE.modules[~s].namespace[~s]"
(symbol->string
(ModuleLocator-name
(ModuleVariable-module-name n)))
(symbol->string (ModuleVariable-name n)))])]))
names)
",")
(string-join (map
@ -145,4 +155,7 @@
[(AliasModuleName!? op)
(format "MACHINE.modules[~s] = MACHINE.modules[~s];"
(symbol->string (ModuleLocator-name (AliasModuleName!-to op)))
(symbol->string (ModuleLocator-name (AliasModuleName!-from op))))]))
(symbol->string (ModuleLocator-name (AliasModuleName!-from op))))]
[(FinalizeModuleInvokation!? op)
(format "MACHINE.modules[~s].finalizeModuleInvokation();")]))

23
js-assembler/mini-runtime.js
View File

@ -98,9 +98,22 @@
this.label = label;
this.isInvoked = false;
this.prefix = false;
this.namespace = {};
};
// Returns access to the names defined in the module.
ModuleRecord.prototype.getNamespace = function() {
return this.namespace;
};
ModuleRecord.prototype.finalizeModuleInvokation = function() {
var i, len = this.prefix.names.length;
for (i=0; i < len; i++) {
this.namespace[this.prefix.names[i]] = this.prefix[i];
}
};
// External invokation of a module.
ModuleRecord.prototype.invoke = function(MACHINE, succ, fail) {
var oldErrorHandler = MACHINE.params['currentErrorHandler'];
var afterGoodInvoke = function(MACHINE) {
@ -113,11 +126,13 @@
} else {
MACHINE.params['currentErrorHandler'] = function(MACHINE, anError) {
MACHINE.params['currentErrorHandler'] = oldErrorHandler;
setTimeout(function() { fail(MACHINE, anError)}, 0);
setTimeout(
function() {
fail(MACHINE, anError)
},
0);
};
MACHINE.control.push(new CallFrame(
afterGoodInvoke,
null));
MACHINE.control.push(new CallFrame(afterGoodInvoke, null));
trampoline(MACHINE, this.label);
}
};

2
simulator/simulator-structs.rkt
View File

@ -74,7 +74,7 @@
[self-path : Symbol]
[label : Symbol]
[invoked? : Boolean]
[exports : (HashTable Symbol PrimitiveValue)]
[namespace : (HashTable Symbol PrimitiveValue)]
[toplevel : (U False toplevel)])
#:transparent
#:mutable)

76
simulator/simulator.rkt
View File

@ -337,17 +337,19 @@
[(ExtendEnvironment/Prefix!? op)
(env-push! m
(make-toplevel (ExtendEnvironment/Prefix!-names op)
(map (lambda: ([name : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? name #f)
(make-undefined)]
[(symbol? name)
(lookup-primitive name)]
[(GlobalBucket? name)
(lookup-primitive (GlobalBucket-name name))]
[(ModuleVariable? name)
(lookup-primitive (ModuleVariable-name name))]))
(ExtendEnvironment/Prefix!-names op))))]
(make-toplevel
(ExtendEnvironment/Prefix!-names op)
(map (lambda: ([name : (U False Symbol GlobalBucket ModuleVariable)])
(cond [(eq? name #f)
(make-undefined)]
[(symbol? name)
(lookup-primitive name)]
[(GlobalBucket? name)
(lookup-primitive
(GlobalBucket-name name))]
[(ModuleVariable? name)
(lookup-module-variable m name)]))
(ExtendEnvironment/Prefix!-names op))))]
[(InstallClosureValues!? op)
(let: ([a-proc : SlotValue (machine-proc m)])
@ -482,9 +484,59 @@
(hash-set! (machine-modules m)
(ModuleLocator-name (AliasModuleName!-to op))
module-record)
'ok)])))
'ok)]
[(FinalizeModuleInvokation!? op)
(let* ([mrecord
(hash-ref (machine-modules m)
(ModuleLocator-name (FinalizeModuleInvokation!-path op)))]
[ns (module-record-namespace mrecord)]
[top
(module-record-toplevel mrecord)])
(cond
[(toplevel? top)
(for-each (lambda: ([n : (U False Symbol GlobalBucket ModuleVariable)]
[v : PrimitiveValue])
(cond
[(eq? n #f)
(void)]
[(symbol? n)
(hash-set! ns n v)]
[(GlobalBucket? n)
(hash-set! ns (GlobalBucket-name n) v)]
[(ModuleVariable? n)
(hash-set! ns (ModuleVariable-name n) v)]))
(toplevel-names top)
(toplevel-vals top))
'ok]
[(eq? top #f)
;; This should never happen. But let's make sure we can see the
;; error.
(error 'FinalizeModuleInvokation
"internal error: toplevel hasn't been initialized.")]))])))
(: lookup-module-variable (machine ModuleVariable -> PrimitiveValue))
(define (lookup-module-variable m mv)
(cond
[(or (eq?
(ModuleLocator-name
(ModuleVariable-module-name mv))
'#%kernel)
(eq?
(ModuleLocator-name
(ModuleVariable-module-name mv))
'whalesong/lang/kernel.rkt))
(lookup-primitive (ModuleVariable-name mv))]
[else
(let ([mrecord
(hash-ref (machine-modules m)
(ModuleLocator-name (ModuleVariable-module-name mv)))])
(hash-ref (module-record-namespace mrecord)
(ModuleVariable-name mv)))]))
(: mutable-pair-list->list ((U Null MutablePair) -> (Listof PrimitiveValue)))
(define (mutable-pair-list->list mlst)