diff --git a/boot.sml b/boot.sml index ff8928a9..2147a6b2 100644 --- a/boot.sml +++ b/boot.sml @@ -43,12 +43,11 @@ fun error ss = LogErr.hostError ss val langEd = 4 -fun lookupRoot (prog:Fixture.PROGRAM) +fun lookupRoot (rootRib:Ast.RIB) (n:Ast.NAME) : Ast.CLASS = let - val rib = Fixture.getRootRib prog - val fix = Fixture.getFixture rib (Ast.PropName n) + val fix = Fixture.getFixture rootRib (Ast.PropName n) in case fix of Ast.ClassFixture cls => cls @@ -61,13 +60,13 @@ fun instantiateRootClass (regs:Mach.REGS) (proto:Mach.OBJ) : (Ast.CLASS * Mach.OBJ) = let - val prog = (#prog regs) - val cls = lookupRoot prog fullName - val clsClass = lookupRoot prog Name.intrinsic_Class - val Ast.Class { classRib, instanceRib, ... } = cls + val rootRib = (#rootRib regs) + val cls = lookupRoot rootRib fullName + val Ast.Class { classRib, ... } = cls + val clsClass = lookupRoot rootRib Name.intrinsic_Class val _ = trace ["allocating class ", LogErr.name fullName]; - val obj = Mach.newObject (Mach.PrimitiveTag (Mach.ClassPrimitive cls)) (Mach.Object proto) instanceRib + val obj = Mach.newObject (Mach.PrimitiveTag (Mach.ClassPrimitive cls)) (Mach.Object proto) classRib val classRegs = Eval.extendScopeReg regs obj Mach.InstanceScope @@ -115,7 +114,7 @@ fun completeClassFixtures (regs:Mach.REGS) * by name until just now. *) val classRegs = Eval.extendScopeReg regs classObj Mach.InstanceScope - val Ast.Class { instanceRib, ... } = lookupRoot (#prog regs) Name.intrinsic_Class + val Ast.Class { instanceRib, ... } = lookupRoot (#rootRib regs) Name.intrinsic_Class in Eval.allocObjRib classRegs classObj (SOME classObj) instanceRib end @@ -135,42 +134,42 @@ fun runConstructorOnObject (regs:Mach.REGS) Eval.initializeAndConstruct classRegs class classObj [] obj end -fun loadFile (prog:Fixture.PROGRAM) +fun loadFile (rootRib:Ast.RIB) (f:string) - : (Fixture.PROGRAM * Ast.FRAGMENT) = + : (Ast.RIB * Ast.FRAGMENT) = let val _ = trace ["parsing boot file ", f] val frag = Parser.parseFile f val _ = trace ["defining boot file ", f] in - Defn.defTopFragment prog frag langEd + Defn.defTopFragment rootRib frag langEd end -fun loadFiles (prog:Fixture.PROGRAM) +fun loadFiles (rootRib:Ast.RIB) (fs:string list) - : (Fixture.PROGRAM * ((string * Ast.FRAGMENT) list)) = + : (Ast.RIB * ((string * Ast.FRAGMENT) list)) = let - fun f prog accum (file::files) = + fun f rootRib accum (file::files) = let val _ = trace ["parsing and defining boot file ", file] val frag = Parser.parseFile file - val (prog', frag') = Defn.defTopFragment prog frag langEd + val (rootRib', frag') = Defn.defTopFragment rootRib frag langEd in - f prog' ((file, frag')::accum) files + f rootRib' ((file, frag')::accum) files end - | f prog accum _ = (prog, List.rev accum) + | f rootRib accum _ = (rootRib, List.rev accum) in - f prog [] fs + f rootRib [] fs end val verifyBuiltins = ref false (* FIXME *) -fun verifyFiles prog fs = +fun verifyFiles rootRib fs = let fun ver (file, frag) = (trace ["verifying boot file ", file]; (file, - Verify.verifyTopFragment prog (!verifyBuiltins) frag)) + Verify.verifyTopFragment rootRib (!verifyBuiltins) frag)) in map ver fs end @@ -210,7 +209,7 @@ fun describeGlobal (regs:Mach.REGS) = (trace ["contents of global object:"]; Mach.inspect (Mach.Object (#global regs)) 1; trace ["contents of top rib:"]; - Fixture.printRib (Fixture.getRootRib (#prog regs))) + Fixture.printRib (#rootRib regs)) else () @@ -242,7 +241,7 @@ fun boot (baseDir:string) : Mach.REGS = val dir = OS.Path.joinDirFile {dir = baseDir, file = "builtins"} fun builtin file = OS.Path.joinDirFile {dir = dir, file = file} val _ = Native.registerNatives (); - val prog = Fixture.mkProgram Defn.initRib + val rootRib = Defn.initRib (* * We have to do a small bit of delicate work here because we have to @@ -257,13 +256,13 @@ fun boot (baseDir:string) : Mach.REGS = * Class and Function. *) - val (prog, objFrag) = loadFile prog (builtin "Object.es") - val (prog, clsFrag) = loadFile prog (builtin "Class.es") - val (prog, funFrag) = loadFile prog (builtin "Function.es") - val (prog, ifaceFrag) = loadFile prog (builtin "Interface.es") + val (rootRib, objFrag) = loadFile rootRib (builtin "Object.es") + val (rootRib, clsFrag) = loadFile rootRib (builtin "Class.es") + val (rootRib, funFrag) = loadFile rootRib (builtin "Function.es") + val (rootRib, ifaceFrag) = loadFile rootRib (builtin "Interface.es") - val (prog, otherFrags) = - loadFiles prog + val (rootRib, otherFrags) = + loadFiles rootRib [builtin "Namespace.es", builtin "Helper.es", builtin "Conversions.es", @@ -324,18 +323,18 @@ fun boot (baseDir:string) : Mach.REGS = val glob = let - val cls = lookupRoot prog Name.public_Object + val cls = lookupRoot rootRib Name.public_Object in - Mach.newObject (Mach.InstanceTag cls) Mach.Null (Fixture.getRootRib prog) + Mach.newObject (Mach.InstanceTag cls) Mach.Null rootRib end - val objFrag = Verify.verifyTopFragment prog (!verifyBuiltins) objFrag - val clsFrag = Verify.verifyTopFragment prog (!verifyBuiltins) clsFrag - val funFrag = Verify.verifyTopFragment prog (!verifyBuiltins) funFrag - val ifaceFrag = Verify.verifyTopFragment prog (!verifyBuiltins) ifaceFrag - val otherProgs = verifyFiles prog otherFrags + val objFrag = Verify.verifyTopFragment rootRib (!verifyBuiltins) objFrag + val clsFrag = Verify.verifyTopFragment rootRib (!verifyBuiltins) clsFrag + val funFrag = Verify.verifyTopFragment rootRib (!verifyBuiltins) funFrag + val ifaceFrag = Verify.verifyTopFragment rootRib (!verifyBuiltins) ifaceFrag + val _ = verifyFiles rootRib otherFrags - val regs = Mach.makeInitialRegs prog glob + val regs = Mach.makeInitialRegs rootRib glob val _ = Mach.setBooting regs true (* BEGIN SPEED HACK *) @@ -348,7 +347,7 @@ fun boot (baseDir:string) : Mach.REGS = (* END SPEED HACK *) (* Build the Object and Function prototypes as instances of public::Object first. *) - val objClass = lookupRoot prog Name.public_Object + val objClass = lookupRoot rootRib Name.public_Object val Ast.Class { instanceRib, ... } = objClass val objPrototype = Mach.newObject (Mach.InstanceTag objClass) Mach.Null instanceRib val funPrototype = Mach.newObject (Mach.InstanceTag objClass) (Mach.Object objPrototype) instanceRib diff --git a/defn.sml b/defn.sml index 9399904f..3a7f54a0 100644 --- a/defn.sml +++ b/defn.sml @@ -119,7 +119,7 @@ type ENV = openNamespaces: Ast.NAMESPACE list list, labels: LABEL list, defaultNamespace: Ast.NAMESPACE, - program: Fixture.PROGRAM, + rootRib: Ast.RIB, func: Ast.FUNC option } @@ -267,30 +267,6 @@ fun resolve (env:ENV) : (Ast.RIBS * Ast.NAME * Ast.FIXTURE) = Fixture.resolveNameExpr (getFullRibs env) (defNameExpr env nameExpr) -(* - Create a new context initialised with the provided rib and - inherited environment -*) - -fun enterFragment (env:ENV) - (frag:Ast.FRAGMENT) - : ENV = - let - val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, defaultNamespace, program, func } = env - - val (newProgram, newDefaultNs, newOpenNss) = - (program, defaultNamespace, openNamespaces) - in - { innerRibs = innerRibs, - outerRibs = outerRibs, - tempOffset = tempOffset, - openNamespaces = newOpenNss, - labels = labels, - defaultNamespace = newDefaultNs, - program = newProgram, - func = func } - end fun extendEnvironment (env:ENV) @@ -299,8 +275,7 @@ fun extendEnvironment (env:ENV) : ENV = let val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, - defaultNamespace, program, func } = env + labels, defaultNamespace, rootRib, func } = env val (newInnerRibs, newOuterRibs) = if hoistingPoint then ([], rib :: (innerRibs @ outerRibs)) else (rib :: innerRibs, outerRibs) @@ -311,16 +286,16 @@ fun extendEnvironment (env:ENV) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func } end -fun mergeRibs (program:Fixture.PROGRAM) +fun mergeRibs (rootRib:Ast.RIB) (oldRib:Ast.RIB) (additions:Ast.RIB) : Ast.RIB = - Fixture.mergeRibs (Type.matches program []) oldRib additions + Fixture.mergeRibs (Type.matches rootRib []) oldRib additions (* FIXME: calls some pretty-hairy type code - needed? *) @@ -336,10 +311,9 @@ fun addToInnerRib (env:ENV) : ENV = let val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, - defaultNamespace, program, func } = env + labels, defaultNamespace, rootRib, func } = env val (innerRib, rest) = headAndTailOfRibs innerRibs - val newInnerRib = mergeRibs (#program env) innerRib additions + val newInnerRib = mergeRibs (#rootRib env) innerRib additions val newInnerRibs = newInnerRib :: rest in { innerRibs = newInnerRibs, @@ -348,7 +322,7 @@ fun addToInnerRib (env:ENV) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func } end @@ -359,9 +333,9 @@ fun addToOuterRib (env:ENV) let val { innerRibs, outerRibs, tempOffset, openNamespaces, labels, - defaultNamespace, program, func } = env + defaultNamespace, rootRib, func } = env val (outerRib, rest) = headAndTailOfRibs outerRibs - val newOuterRib = mergeRibs (#program env) outerRib additions + val newOuterRib = mergeRibs (#rootRib env) outerRib additions val newOuterRibs = newOuterRib :: rest in { innerRibs = innerRibs, @@ -370,7 +344,7 @@ fun addToOuterRib (env:ENV) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func } end @@ -379,7 +353,7 @@ fun updateTempOffset (env:ENV) (newTempOffset:int) : ENV = let val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, defaultNamespace, program, func } = env + labels, defaultNamespace, rootRib, func } = env in { innerRibs = innerRibs, outerRibs = outerRibs, @@ -387,7 +361,7 @@ fun updateTempOffset (env:ENV) (newTempOffset:int) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func } end @@ -404,7 +378,7 @@ fun enterClass (env:ENV) Ast.NamespaceFixture protectedNS) ] val env = extendEnvironment env localNamespaceRib true val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, defaultNamespace, program, func } = env + labels, defaultNamespace, rootRib, func } = env val openNamespaces = ([privateNS, protectedNS] @ parentProtectedNSs) :: openNamespaces in ({ innerRibs = innerRibs, @@ -413,7 +387,7 @@ fun enterClass (env:ENV) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func }, localNamespaceRib ) end @@ -423,7 +397,7 @@ fun enterFuncBody (env:ENV) (newFunc:Ast.FUNC) let val { innerRibs, outerRibs, tempOffset, openNamespaces, labels, - defaultNamespace, program, func } = env + defaultNamespace, rootRib, func } = env in { innerRibs = innerRibs, outerRibs = outerRibs, @@ -431,7 +405,7 @@ fun enterFuncBody (env:ENV) (newFunc:Ast.FUNC) openNamespaces = openNamespaces, labels = labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = SOME newFunc } end @@ -453,7 +427,7 @@ fun addLabel ((label:LABEL),(env:ENV)) : ENV = let val { innerRibs, outerRibs, tempOffset, openNamespaces, - labels, defaultNamespace, program, func } = env + labels, defaultNamespace, rootRib, func } = env val (labelId,labelKnd) = label in dumpLabels labels; @@ -469,7 +443,7 @@ fun addLabel ((label:LABEL),(env:ENV)) openNamespaces = openNamespaces, labels = label::labels, defaultNamespace = defaultNamespace, - program = program, + rootRib = rootRib, func = func } end @@ -539,8 +513,6 @@ and defInterface (env: ENV) (* Resolve base interface's super interfaces and rib *) val (superInterfaces:Ast.TYPE list, inheritedRib:Ast.RIB) = resolveInterfaces env extends - val prog = (#program env) - (* val groundSuperInterfaceExprs = map (Type.groundExpr o (makeTy env) o (fn t => Type.normalize (getFullRibs env) t)) superInterfaces *) val groundSuperInterfaceExprs = map (makeTy env) superInterfaces @@ -993,8 +965,8 @@ and analyzeClassBody (env:ENV) val _ = trace ["defining class ", fmtName name] val (staticEnv, localNamespaceRib) = enterClass env privateNS protectedNS [] val (unhoisted,classRib,classInits) = defDefns staticEnv classDefns - val classRib = (mergeRibs (#program env) unhoisted classRib) - val classRib = (mergeRibs (#program env) classRib localNamespaceRib) + val classRib = (mergeRibs (#rootRib env) unhoisted classRib) + val classRib = (mergeRibs (#rootRib env) classRib localNamespaceRib) (* namespace and type definitions aren't normally hoisted *) @@ -1365,7 +1337,7 @@ and defFunc (env:ENV) block = blockOpt, defaults = defaults, ty = newT, - param = Ast.Head (mergeRibs (#program env) paramRib hoisted, + param = Ast.Head (mergeRibs (#rootRib env) paramRib hoisted, paramInits), native=native, generator=generator, @@ -1469,7 +1441,7 @@ and defPragmas (env:ENV) (pragmas:Ast.PRAGMA list) : (Ast.PRAGMA list * ENV * Ast.RIB) = let - val program = ref (#program env) + val rootRib = ref (#rootRib env) val innerRibs = #innerRibs env val outerRibs = #outerRibs env val defaultNamespace = ref (#defaultNamespace env) @@ -1486,7 +1458,7 @@ and defPragmas (env:ENV) | _ => !opennss :: (#openNamespaces env)), labels = (#labels env), defaultNamespace = !defaultNamespace, - program = !program, + rootRib = !rootRib, func = (#func env) } fun defPragma x = @@ -1775,7 +1747,7 @@ and defStmt (env:ENV) body = newBody, rib = SOME ur1, next = newNext }, - mergeRibs (#program env) hr1 hoisted) + mergeRibs (#rootRib env) hr1 hoisted) end end @@ -1808,7 +1780,7 @@ and defStmt (env:ENV) SOME vd => defDefn env (Ast.VariableDefn vd) | NONE => ([],[],[]) val (ur,hr,_) = defVarDefnOpt defn - val env = extendEnvironment env (mergeRibs (#program env) ur hr) false + val env = extendEnvironment env (mergeRibs (#rootRib env) ur hr) false val (newInit,_) = defStmts env init val newCond = defExpr env cond val newUpdate = defExpr env update @@ -1822,7 +1794,7 @@ and defStmt (env:ENV) labels = Ustring.empty::labelIds, body = newBody, rib = SOME (ur) }, - (mergeRibs (#program env) hr hoisted) ) + (mergeRibs (#rootRib env) hr hoisted) ) end fun reconstructCatch { bindings, rib, inits, block, ty } = @@ -2047,7 +2019,7 @@ and defStmt (env:ENV) (Ast.IfStmt { cnd = cnd, thn = thn, els = els }, - mergeRibs (#program env) thn_hoisted els_hoisted) + mergeRibs (#rootRib env) thn_hoisted els_hoisted) end | Ast.WithStmt { obj, ty, body } => @@ -2111,7 +2083,7 @@ and defStmts (env) (stmts:Ast.STATEMENT list) val env = addToOuterRib env f1 val (s2, f2) = defStmts env stmts in - (s1::s2,(mergeRibs (#program env) f1 f2)) + (s1::s2,(mergeRibs (#rootRib env) f1 f2)) end | [] => ([],[]) @@ -2246,14 +2218,14 @@ and defDefns (env:ENV) [] => (unhoisted, hoisted, inits) | d::ds => let - val { program, ... } = env + val { rootRib, ... } = env val (unhoisted', hoisted', inits') = defDefn env d val env = addToOuterRib env hoisted' val env = addToInnerRib env unhoisted' val _ = trace(["defDefns: combining unhoisted ribs"]); - val combinedUnHoisted = mergeRibs program unhoisted unhoisted' + val combinedUnHoisted = mergeRibs rootRib unhoisted unhoisted' val _ = trace(["defDefns: combining hoisted ribs"]); - val combinedHoisted = mergeRibs program hoisted hoisted' + val combinedHoisted = mergeRibs rootRib hoisted hoisted' val _ = trace(["defDefns: combining inits"]) val combinedInits = inits @ inits' in @@ -2307,18 +2279,18 @@ and defBlockFull (env:ENV) else extendEnvironment env [] false val (pragmas, env, unhoisted_pragma_fxtrs) = defPragmas env pragmas val (unhoisted_defn_fxtrs, hoisted_defn_fxtrs, inits) = defDefns env defns - val unhoisted = mergeRibs (#program env) + val unhoisted = mergeRibs (#rootRib env) unhoisted_defn_fxtrs unhoisted_pragma_fxtrs val env = addToOuterRib env hoisted_defn_fxtrs val env = addToInnerRib env unhoisted val (body, hoisted_body_fxtrs) = defStmts env body - val hoisted = mergeRibs (#program env) hoisted_defn_fxtrs hoisted_body_fxtrs + val hoisted = mergeRibs (#rootRib env) hoisted_defn_fxtrs hoisted_body_fxtrs val contained = if decorative then [] else unhoisted val escaped = if decorative - then mergeRibs (#program env) hoisted unhoisted + then mergeRibs (#rootRib env) hoisted unhoisted else hoisted in (Ast.Block { pragmas = pragmas, @@ -2337,22 +2309,18 @@ and defBlockFull (env:ENV) and defFragment (env:ENV) (frag:Ast.FRAGMENT) : (Ast.FRAGMENT * Ast.RIB) = - let - val env = enterFragment env frag - in - case frag of - Ast.Anon blk => - let - val (blk, escaped) = defDecorativeBlock env blk - in - (Ast.Anon blk, escaped) - end - end - -and mkTopEnv (prog:Fixture.PROGRAM) + case frag of + Ast.Anon blk => + let + val (blk, escaped) = defDecorativeBlock env blk + in + (Ast.Anon blk, escaped) + end + +and mkTopEnv (rootRib:Ast.RIB) (langEd:int) : ENV = - { outerRibs = [Fixture.getRootRib prog], + { outerRibs = [rootRib], innerRibs = [], tempOffset = 0, openNamespaces = (if (langEd > 3) @@ -2360,23 +2328,23 @@ and mkTopEnv (prog:Fixture.PROGRAM) else [[Name.publicNS]]), labels = [], defaultNamespace = Name.publicNS, - program = prog, + rootRib = rootRib, func = NONE } and summarizeFragment (Ast.Anon (Ast.Block {head=(SOME (Ast.Head (rib, _))), ...})) = Fixture.printRib rib -and defTopFragment (prog:Fixture.PROGRAM) +and defTopFragment (rootRib:Ast.RIB) (frag:Ast.FRAGMENT) (langEd:int) - : (Fixture.PROGRAM * Ast.FRAGMENT) = + : (Ast.RIB * Ast.FRAGMENT) = let - val topEnv = mkTopEnv prog langEd + val topEnv = mkTopEnv rootRib langEd val (frag, escaped) = defFragment topEnv frag val Ast.Anon (Ast.Block { pragmas, defns, head, body, loc }) = frag val newHead = case head of SOME (Ast.Head (rib, inits)) => - SOME (Ast.Head (mergeRibs prog rib escaped, inits)) + SOME (Ast.Head (mergeRibs rootRib rib escaped, inits)) | NONE => SOME (Ast.Head (escaped, [])) (* @@ -2390,7 +2358,7 @@ and defTopFragment (prog:Fixture.PROGRAM) head = newHead, body = body, loc = loc }) - val prog = Fixture.extendRootRib prog escaped (Type.matches prog []) + val rootRib = mergeRibs rootRib rootRib escaped in trace ["fragment definition complete"]; (if !doTraceSummary @@ -2399,7 +2367,7 @@ and defTopFragment (prog:Fixture.PROGRAM) (if !doTrace then Pretty.ppFragment frag else ()); - (prog, frag) + (rootRib, frag) end end diff --git a/eval.sml b/eval.sml index f265c797..2c388c91 100644 --- a/eval.sml +++ b/eval.sml @@ -41,13 +41,13 @@ open Mach open LogErr -fun log (ss:string list) = log ("[eval] " :: ss) +fun log (ss:string list) = LogErr.log ("[eval] " :: ss) val doTrace = ref false val doTraceConstruct = ref false -fun fmtName n = if (!doTrace orelse !doTraceConstruct) then name n else "" -fun fmtNameExpr n = if (!doTrace orelse !doTraceConstruct) then nameExpr n else "" +fun fmtName n = if (!doTrace orelse !doTraceConstruct) then LogErr.name n else "" +fun fmtNameExpr n = if (!doTrace orelse !doTraceConstruct) then LogErr.nameExpr n else "" fun trace (ss:string list) = if (!doTrace) then log ss else () @@ -57,7 +57,7 @@ fun traceConstruct (ss:string list) = fun error (regs:REGS) (ss:string list) = - (log ("[stack] " :: [stackString (stackOf regs)]); + (LogErr.log ("[stack] " :: [stackString (stackOf regs)]); evalError ss) @@ -65,8 +65,8 @@ fun normalize (regs:REGS) (ty:TYPE) : TYPE = let - val { scope, prog, ... } = regs - val ribs = getRibs scope + val { scope, rootRib, ... } = regs + val ribs = getRibs regs scope in Type.normalize ribs ty end @@ -136,7 +136,7 @@ fun extendScopeReg (r:REGS) (kind:SCOPE_KIND) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, rootRib, aux } = r val scope = extendScope scope ob kind in { scope = scope, @@ -144,7 +144,7 @@ fun extendScopeReg (r:REGS) thisFun = thisFun, thisGen = thisGen, global = global, - prog = prog, + rootRib = rootRib, aux = aux } end @@ -152,14 +152,14 @@ fun withThis (r:REGS) (newThis:OBJ) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, rootRib, aux } = r in { scope = scope, this = newThis, thisFun = thisFun, thisGen = thisGen, global = global, - prog = prog, + rootRib = rootRib, aux = aux } end @@ -167,14 +167,14 @@ fun withThisFun (r:REGS) (newThisFun:OBJ option) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, rootRib, aux } = r in { scope = scope, this = this, thisFun = newThisFun, thisGen = thisGen, global = global, - prog = prog, + rootRib = rootRib, aux = aux } end @@ -182,14 +182,14 @@ fun withThisGen (r:REGS) (newThisGen:OBJ option) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, rootRib, aux } = r in { scope = scope, this = this, thisFun = thisFun, thisGen = newThisGen, global = global, - prog = prog, + rootRib = rootRib, aux = aux } end @@ -197,33 +197,33 @@ fun withScope (r:REGS) (newScope:SCOPE) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, rootRib, aux } = r in { scope = newScope, this = this, thisFun = thisFun, thisGen = thisGen, global = global, - prog = prog, + rootRib = rootRib, aux = aux } end + -fun withProg (r:REGS) - (newProg:Fixture.PROGRAM) +fun withRootRib (r:REGS) + (rootRib:RIB) : REGS = let - val { scope, this, thisFun, thisGen, global, prog, aux } = r + val { scope, this, thisFun, thisGen, global, aux, ... } = r in { scope = scope, this = this, thisFun = thisFun, thisGen = thisGen, global = global, - prog = newProg, + rootRib = rootRib, aux = aux } end - fun getObjId (obj:OBJ) : OBJ_IDENTIFIER = let @@ -413,9 +413,7 @@ fun allocRib (regs:REGS) in allocProp "value" { ty = ty, - state = if writable - then valAllocState regs ty - else UninitProp, + state = valAllocState regs ty, attrs = { removable = false, enumerable = false, writable = if writable @@ -450,7 +448,7 @@ fun allocRib (regs:REGS) val classObj = needObj regs (newClass regs cls) val _ = traceConstruct ["allocating class rib on class ", fmtName pn] (* FIXME: 'this' binding in class objects might be wrong here. *) - val _ = allocObjRib regs classObj NONE classRib + (* val _ = allocObjRib regs classObj NONE classRib *) in allocProp "class" { ty = typename intrinsic_Class, @@ -642,56 +640,27 @@ and valAllocState (regs:REGS) error regs ["allocating fixture of unresolved field type reference"] | ClassType (Class {name, nonnullable, ...}) => - (* It is possible that we're booting and the class n doesn't even exist yet. *) - if (not (isBooting regs)) orelse - isClass (getValue regs (#global regs) name) - then - let - val clsid = getObjId (needObj regs (getValue regs (#global regs) name)) - in - case allocSpecial regs clsid of - SOME v => ValProp v - | NONE => if nonnullable - then UninitProp - else ValProp (Null) - end + (* We cannot go via the class obj id because we may be booting! *) + if nameEq name Name.ES4_double + then ValProp (newDouble regs 0.0) else - if nonnullable - then UninitProp - else ValProp (Null) - + if nameEq name Name.ES4_string + then ValProp (newString regs Ustring.empty) + else + if nameEq name Name.ES4_boolean + then ValProp (newBoolean regs false) + else + if nameEq name Name.ES4_decimal + then ValProp (newDecimal regs Decimal.zero) + else + if nonnullable + then UninitProp + else ValProp (Null) + | InterfaceType (Interface {name, ...}) => UninitProp -and allocSpecial (regs:REGS) - (id:OBJ_IDENTIFIER) - : VALUE option = - let - fun findSpecial [] = NONE - | findSpecial ((q,f)::rest) = - let - val ident = slotObjId regs q - in - if ident = id - then - (traceConstruct ["allocating special builtin"]; SOME (f ())) - else - findSpecial rest - end - in - findSpecial - [ - (getBooleanClassSlot, (fn _ => newBoolean regs false)), - - (getDoubleClassSlot, (fn _ => newDouble regs 0.0)), - (getDecimalClassSlot, (fn _ => newDecimal regs Decimal.zero)), - - (getStringClassSlot, (fn _ => newString regs Ustring.empty)) - ] - end - - and asArrayIndex (v:VALUE) : Word32.word = case v of @@ -1225,6 +1194,21 @@ fun evalDoubleLiteral (env: ENV) and newDouble (regs:REGS) (n:Real64.real) : VALUE = + (* BEGIN_INFORMATIVE *) + if Real64.isNan n + then + let + val dn = getDoubleNaNSlot regs + in + case !dn of + NONE => newPrimitive regs (DoublePrimitive n) getDoubleClassSlot + | SOME obj => Object obj + end + else + case findInDoubleCache regs n of + SOME obj => Object obj + | NONE => + (* END_INFORMATIVE *) newPrimitive regs (DoublePrimitive n) getDoubleClassSlot @@ -1256,7 +1240,20 @@ fun evalBooleanLiteral (env: ENV) and newBoolean (regs:REGS) (b:bool) : VALUE = + (* BEGIN_INFORMATIVE *) + let + val cell = + if b + then getBooleanTrueSlot regs + else getBooleanFalseSlot regs + in + case !cell of + SOME obj => Object obj + | NONE => + (* END_INFORMATIVE *) newPrimitive regs (BooleanPrimitive b) getBooleanClassSlot + end (* INFORMATIVE*) + and newNamespace (regs:REGS) (n:NAMESPACE) @@ -2354,7 +2351,7 @@ and instanceType (regs:REGS) (args:TYPE list) : TYPE = let - val instanceTy = Type.instanceTy (#prog regs) name + val instanceTy = Type.instanceTy (#rootRib regs) name in applyTypes regs instanceTy args end @@ -3972,6 +3969,7 @@ and resolveName (regs:REGS) QualifiedName {identifier, namespace} => (identifier, [[evalNamespaceExpr regs namespace]]) | UnqualifiedName { identifier, openNamespaces } => (identifier, openNamespaces) in + trace ["resolveName: ", LogErr.nameExpr nameExpr]; findName ((#global regs), objects, identifier, openNamespaces) end @@ -4573,7 +4571,8 @@ and constructStandardWithTag (regs:REGS) let val Class { name, instanceRib, ...} = class val instanceObj = newObject tag proto instanceRib - (* FIXME: might have 'this' binding wrong in class scope here. *) + val _ = bindAnySpecialIdentity regs instanceObj + (* FIXME: might have 'this' binding wrong in class scope here. *) val classScope = getClassScope regs classObj val regs = withThis (withScope regs classScope) instanceObj in @@ -4613,7 +4612,7 @@ and parseFunctionFromArgs (regs:REGS) Parser.AllowColon, Parser.AllowIn) - val funcExpr = Defn.defExpr (Defn.mkTopEnv (#prog regs) (getLangEd regs)) funcExpr + val funcExpr = Defn.defExpr (Defn.mkTopEnv (#rootRib regs) (getLangEd regs)) funcExpr in (fullStr, funcExpr) end @@ -4687,6 +4686,48 @@ and specialPrimitiveCopyingConstructor (regs:REGS) obj end + +and specialClassConstructor (regs:REGS) + (classObj:OBJ) + (class:CLASS) + (args:VALUE list) + : OBJ = + let + (* Here we have class and classObj carrying the class "__ES4__::Class", and + * our *sole argument* carrying the class we're constructing. We cannot just + * construct an instance of class/classObj though, because they do not carry + * the classrib we want. We need to synthesize a metaclass and + * instantiate *that*. + * + * FIXME: possibly shift this to defn phase. Unclear. + *) + val proto = getPrototype regs classObj + val Class publicClass = class + val Class targetClass = case args of + (Object (Obj { tag=PrimitiveTag (ClassPrimitive c), ...}) :: _) => c + | _ => error regs ["called special class constructor without class object"] + val metaClass = Class { name = Name.empty, (* FIXME: need to pick a name for the metaclass, sigh. *) + privateNS = (#privateNS targetClass), + protectedNS = (#protectedNS targetClass), + parentProtectedNSs = (#parentProtectedNSs targetClass), + typeParams = (#typeParams targetClass), + + nonnullable = (#nonnullable publicClass), + dynamic = (#dynamic publicClass), + extends = SOME (ClassType (Class publicClass)), + implements = [], + classRib = [], + instanceRib = Fixture.mergeRibs (Type.matches (#rootRib regs) []) (#instanceRib publicClass) (#classRib targetClass), + instanceInits = Head ([],[]), + constructor = NONE, + classType = Ast.RecordType [] (* FIXME: bogus, #classType probably needs to go. *) } + + val metaClassObj = newObject (InstanceTag (Class publicClass)) Null [] + + in + constructStandardWithTag regs metaClassObj metaClass (PrimitiveTag (ClassPrimitive (Class targetClass))) proto args + end + and specialObjectConstructor (regs:REGS) (classObj:OBJ) (class:CLASS) @@ -4853,7 +4894,7 @@ and constructSpecial (regs:REGS) in findSpecial [ - (getClassClassSlot, specialPrimitiveCopyingConstructor), + (getClassClassSlot, specialClassConstructor), (getInterfaceClassSlot, specialPrimitiveCopyingConstructor), (getNamespaceClassSlot, specialPrimitiveCopyingConstructor), @@ -4909,7 +4950,6 @@ and bindAnySpecialIdentity (regs:REGS) NONE => () | SOME (_,func) => let - (*val _ = TextIO.print ("binding special identity for class " ^ name name ^ "\n")*) val _ = trace ["binding special identity for class ", fmtName name] val cell = func regs in @@ -5096,7 +5136,6 @@ and constructClassInstance (regs:REGS) SOME ob => ob | NONE => constructStandard regs classObj class (getPrototype regs classObj) args in - bindAnySpecialIdentity regs obj; initClassPrototype regs obj; (* INFORMATIVE *) pop regs; Object obj diff --git a/fixture.sml b/fixture.sml index a50ba9bb..bf78fd8c 100755 --- a/fixture.sml +++ b/fixture.sml @@ -173,55 +173,6 @@ fun printRib (rib:Ast.RIB) = List.app printFixture rib -(* ----------------------------------------------------------------------------- - * Operations on PROGRAMs - * ----------------------------------------------------------------------------- *) - -type PROGRAM = { rootRib: Ast.RIB, - packageNames: ((Ast.IDENTIFIER list) list) } - - -fun mkProgram (topRib:Ast.RIB) - : PROGRAM = - { rootRib = topRib, - packageNames = [] } - - -fun extendRootRib (prog:PROGRAM) - (additions:Ast.RIB) - (tyeq:TYEQ) - : PROGRAM = - let - val { packageNames, ... } = prog - val oldRib = (#rootRib prog) - val newRib = mergeRibs tyeq oldRib additions - in - { rootRib = newRib, - packageNames = packageNames } - end - - -fun getRootRib (prog:PROGRAM) - : Ast.RIB = - (#rootRib prog) - - -fun addPackageName (prog:PROGRAM) - (packageName:Ast.IDENTIFIER list) - : PROGRAM = - let - val { rootRib, ... } = prog - in - { rootRib = rootRib, - packageNames = (packageName :: (#packageNames prog)) } - end - - -fun getPackageNames (prog:PROGRAM) - : Ast.IDENTIFIER list list = - (#packageNames prog) - - (* ----------------------------------------------------------------------------- * Static variant of name-resolution algorithm: mirrors Mach.findName * ----------------------------------------------------------------------------- *) diff --git a/mach.sml b/mach.sml index e7096e3b..d9370a4d 100644 --- a/mach.sml +++ b/mach.sml @@ -93,8 +93,8 @@ datatype VALUE = Undefined Obj of { props: PROPERTY_BINDINGS, proto: VALUE, ident: OBJ_IDENTIFIER, - tag: TAG - , rib: RIB + tag: TAG, + rib: RIB } and TAG = @@ -260,7 +260,7 @@ withtype FUN_CLOSURE = thisFun: OBJ option, thisGen: OBJ option, global: OBJ, - prog: Fixture.PROGRAM + rootRib: RIB , aux: AUX (* INFORMATIVE *) } @@ -270,7 +270,7 @@ withtype FUN_CLOSURE = thisFun: OBJ option, thisGen: OBJ option, global: OBJ, - prog: Fixture.PROGRAM, + rootRib: RIB, aux: AUX } (* REGS *) -> VALUE list -> VALUE), length: int } @@ -456,23 +456,29 @@ fun hasFixedProp (b:PROPERTY_BINDINGS) fun hasPrimitive (Obj { tag = PrimitiveTag _, ... }) = true | hasPrimitive _ = false -fun getRib (obj:OBJ) +fun getObjId (Obj { ident, ...}) = ident +fun getRib (regs:REGS) + (obj:OBJ) : RIB = let - val Obj { rib, ... } = obj + val { rootRib, global, ... } = regs + val Obj { rib, ident, ... } = obj in - rib + if (getObjId global) = ident + then rootRib + else rib end -fun getRibs (scope:SCOPE) +fun getRibs (regs:REGS) + (scope:SCOPE) : RIBS = let val Scope {object, parent, ...} = scope - val rib = getRib object + val rib = getRib regs object in case parent of NONE => [rib] - | SOME p => rib :: (getRibs p) + | SOME p => rib :: (getRibs regs p) end @@ -514,7 +520,6 @@ fun newObject (t:TAG) proto = p, rib = rib } - fun newObjectNoTag (rib:RIB) : OBJ = newObject NoTag Null rib @@ -749,8 +754,8 @@ fun inspect (v:VALUE) ValProp v => subVal indent v | _ => TextIO.print (stateStr ^ "\n") end - val Obj { props, proto, ... } = obj - val { bindings, ... } = !props + val Obj { props, proto, rib, ... } = obj + val { bindings, ... } = !props in TextIO.print "Obj {\n"; p indent [" tag = ", (tag obj)]; nl(); @@ -758,7 +763,11 @@ fun inspect (v:VALUE) p indent [" proto = "]; subVal indent (proto); p indent [" props = ["]; nl(); NameMap.appi prop bindings; - p indent [" ] }"]; nl() + p indent [" ]"]; nl(); + p indent [" rib = "]; nl(); + Fixture.printRib rib; + p indent ["}"]; + nl () end in printVal 0 d v @@ -914,7 +923,7 @@ fun push (regs:REGS) profileMap }, ... }, ... } = regs - val _ = if length (!stack) > 128 + val _ = if length (!stack) > 512 then error ["very deep stack, likely infinite recursion"] else () val newStack = (Frame { name = name, args = args }) :: (!stack) @@ -1099,7 +1108,7 @@ fun makeGlobalScopeWith (global:OBJ) temps = ref [], kind = GlobalScope } -fun makeInitialRegs (prog:Fixture.PROGRAM) +fun makeInitialRegs (rootRib:RIB) (glob:OBJ) : REGS = let @@ -1144,7 +1153,7 @@ fun makeInitialRegs (prog:Fixture.PROGRAM) thisFun = NONE, thisGen = NONE, scope = makeGlobalScopeWith glob, - prog = prog, + rootRib = rootRib, aux = aux } end @@ -1318,7 +1327,7 @@ fun searchScope (scope : SCOPE, | (WithScope, false) => NONE - | (_,_) + | (_,_) => searchObject (SOME object, identifier, namespaces, fixedOnly) end @@ -1360,8 +1369,6 @@ fun instanceRibsOf (object: OBJECT) : RIBS = [] -fun getObjId (Obj { ident, ...}) = ident - fun findName (globalObj: OBJECT, objects: OBJECT list, identifier: IDENTIFIER, openNamespaces: OPEN_NAMESPACES) : (OBJECT * NAME) option = let diff --git a/main.sml b/main.sml index a2f7f15c..f082c8f9 100644 --- a/main.sml +++ b/main.sml @@ -180,40 +180,40 @@ fun parse argvRest = (TextIO.print "parsing ... \n"; List.map Parser.parseFile argvRest) -fun define prog argvRest = +fun define rootRib argvRest = let val frags = parse argvRest - fun f prog accum (frag::frags) = + fun f rootRib accum (frag::frags) = let - val (prog', frag') = Defn.defTopFragment prog frag (!langEd) + val (rootRib', frag') = Defn.defTopFragment rootRib frag (!langEd) in - f prog' (frag'::accum) frags + f rootRib' (frag'::accum) frags end - | f prog accum _ = (prog, List.rev accum) + | f rootRib accum _ = (rootRib, List.rev accum) in TextIO.print "defining ... \n"; - f prog [] frags + f rootRib [] frags end -fun verify prog argvRest = +fun verify rootRib argvRest = let - val (prog, frags) = define prog argvRest - fun f prog accum (frag::frags) = + val (rootRib, frags) = define rootRib argvRest + fun f rootRib accum (frag::frags) = let - val frag' = Verify.verifyTopFragment prog true frag + val frag' = Verify.verifyTopFragment rootRib true frag in - f prog (frag'::accum) frags + f rootRib (frag'::accum) frags end - | f prog accum _ = (prog, List.rev accum) + | f rootRib accum _ = (rootRib, List.rev accum) in TextIO.print "verifying ... \n"; - f prog [] frags + f rootRib [] frags end fun eval regs argvRest = let - val (prog, frags) = verify (#prog regs) argvRest - val regs = Eval.withProg regs prog + val (rootRib, frags) = verify (#rootRib regs) argvRest + val regs = Eval.withRootRib regs rootRib in Mach.setLangEd regs (!langEd); Posix.Process.alarm (Time.fromReal 300.0); @@ -317,10 +317,10 @@ fun repl (regs:Mach.REGS) in if not (!doDefn) then () else let - val (prog, frag) = Defn.defTopFragment (#prog (!regsCell)) frag (!langEd) - val frag = Verify.verifyTopFragment prog true frag + val (rootRib, frag) = Defn.defTopFragment (#rootRib (!regsCell)) frag (!langEd) + val frag = Verify.verifyTopFragment rootRib true frag in - regsCell := Eval.withProg regs prog; + regsCell := Eval.withRootRib regs rootRib; if not (!doEval) then () else let val regs = !regsCell @@ -385,8 +385,8 @@ and main (dump:string -> bool) HelpCommand => (usage (); success) | ReplCommand => (repl (getRegs()) dump readLine; success) | ParseCommand files => (parse files; success) - | DefineCommand files => (define (#prog (getRegs())) files; success) - | VerifyCommand files => (verify (#prog (getRegs())) files; success) + | DefineCommand files => (define (#rootRib (getRegs())) files; success) + | VerifyCommand files => (verify (#rootRib (getRegs())) files; success) | EvalCommand files => (eval (getRegs()) files; success) | ResetCommand => let diff --git a/native.sml b/native.sml index ed0a54df..c2f3f044 100644 --- a/native.sml +++ b/native.sml @@ -579,14 +579,14 @@ fun eval (regs:Mach.REGS) val frag = Parser.parseLines lines handle LogErr.LexError le => raise Eval.ThrowException (str le) | LogErr.ParseError pe => raise Eval.ThrowException (str pe) - val (prog, frag) = (Defn.defTopFragment (#prog regs) frag (Mach.getLangEd regs) - handle - LogErr.DefnError de => raise Eval.ThrowException (str de)) - val _ = (Verify.verifyTopFragment prog false frag + val (rootRib, frag) = (Defn.defTopFragment (#rootRib regs) frag (Mach.getLangEd regs) + handle + LogErr.DefnError de => raise Eval.ThrowException (str de)) + val _ = (Verify.verifyTopFragment rootRib false frag handle LogErr.VerifyError ve => raise Eval.ThrowException (str ve)) - val regs = Eval.withProg regs prog + val regs = Eval.withRootRib regs rootRib in (* * FIXME: maybe don't want to permit the full set of @@ -837,13 +837,13 @@ fun load (regs:Mach.REGS) val frag = Parser.parseFile fname handle LogErr.LexError le => raise Eval.ThrowException (str le) | LogErr.ParseError pe => raise Eval.ThrowException (str pe) - val (prog, frag) = (Defn.defTopFragment (#prog regs) frag (Mach.getLangEd regs) + val (rootRib, frag) = (Defn.defTopFragment (#rootRib regs) frag (Mach.getLangEd regs) handle LogErr.DefnError de => raise Eval.ThrowException (str de)) - val _ = (Verify.verifyTopFragment prog false frag + val _ = (Verify.verifyTopFragment rootRib false frag handle LogErr.VerifyError ve => raise Eval.ThrowException (str ve)) - val regs = Eval.withProg regs prog + val regs = Eval.withRootRib regs rootRib in Eval.evalTopFragment regs frag @@ -1090,7 +1090,7 @@ fun registerNatives _ = addFn 1 Name.informative_floorDecimal floorDecimal; addFn 1 Name.informative_logDouble logDouble; addFn 1 Name.informative_logDecimal logDecimal; - addFn 2 Name.informative_powDouble powDouble; + addFn 2 Name.informative_powDouble pow; addFn 2 Name.informative_powDecimal powDecimal; addFn 1 Name.informative_roundDouble roundDouble; addFn 1 Name.informative_roundDecimal roundDecimal; diff --git a/spec/stitch.py b/spec/stitch.py index 874b3dc9..26a1dcd8 100644 --- a/spec/stitch.py +++ b/spec/stitch.py @@ -244,9 +244,21 @@ def extractSML(fn, name): blanks = 0 prev = "" ldots = re.compile("\(\* *LDOTS *\*\)") + skipping = False for line in f: # Skip informative lines + if skipping: + continue + + if re.search("BEGIN_INFORMATIVE", line): + skipping = True + continue + + if re.search("END_INFORMATIVE", line): + skipping = False + continue + if re.search("INFORMATIVE", line): continue diff --git a/tests/spidermonkey/ecma/shell.js b/tests/spidermonkey/ecma/shell.js index a4826573..84db0560 100644 --- a/tests/spidermonkey/ecma/shell.js +++ b/tests/spidermonkey/ecma/shell.js @@ -85,7 +85,7 @@ function TestCase( n, d, e, a ) { this.reason = ""; this.bugnumber = BUGNUMBER; - //this.passed = getTestCaseResult( this.expect, this.actual ); + // this.passed = getTestCaseResult( this.expect, this.actual ); if ( DEBUG ) { print( "added " + this.description ); } @@ -190,8 +190,8 @@ function getTestCaseResult( expect, actual ) { //check if its a date if ((expect.indexOf('GMT+0000') > -1) && (actual.indexOf('GMT+0000') > -1)) { // let the dates be off by one second - var eSec = int(expect.split(':')[2].split(' ')[0]); - var aSec = int(actual.split(':')[2].split(' ')[0]); + var eSec = toInt(expect.split(':')[2].split(' ')[0]); + var aSec = toInt(actual.split(':')[2].split(' ')[0]); var diff = Math.abs(eSec-aSec); if ((diff == 1) || (diff == 59)) { passed = true; diff --git a/tools/unit.sml b/tools/unit.sml index a3fd36ed..207f2344 100755 --- a/tools/unit.sml +++ b/tools/unit.sml @@ -314,9 +314,9 @@ fun runTestCase (regs:Mach.REGS) (test : TEST_CASE) : TEST_RESULT = | { name, stage=Verify, arg, source } => (let val frag = parse source - val (prog, frag) = Defn.defTopFragment (#prog regs) frag 4 + val (rootRib, frag) = Defn.defTopFragment (#rootRib regs) frag 4 val _ = (Verify.warningsAreFailures := true ) - val frag = Verify.verifyTopFragment prog true frag + val frag = Verify.verifyTopFragment rootRib true frag in (test, if arg then true else false) end @@ -326,8 +326,8 @@ fun runTestCase (regs:Mach.REGS) (test : TEST_CASE) : TEST_RESULT = | { name, stage=Eval, arg, source } => (let val frag = parse source - val (prog, frag) = Defn.defTopFragment (#prog regs) frag 4 - val frag = Verify.verifyTopFragment prog true frag + val (rootRib, frag) = Defn.defTopFragment (#rootRib regs) frag 4 + val frag = Verify.verifyTopFragment rootRib true frag val res = Eval.evalTopFragment regs frag in (test, if arg then true else false) diff --git a/type.sml b/type.sml index 07ac670c..f5c1d026 100755 --- a/type.sml +++ b/type.sml @@ -954,15 +954,15 @@ fun groundMatches type1 type2 type1 type2 *) -fun matches (prog:Fixture.PROGRAM) +fun matches (rootRib:RIB) (locals:RIBS) (type1:TYPE) (type2:TYPE) = let (* FIXME: it is *super wrong* to just be using the root rib here. *) - val norm1 = normalize (locals @ [Fixture.getRootRib prog]) type1 - val norm2 = normalize (locals @ [Fixture.getRootRib prog]) type2 + val norm1 = normalize (locals @ [rootRib]) type1 + val norm2 = normalize (locals @ [rootRib]) type2 in groundMatches norm1 norm2 end @@ -972,20 +972,20 @@ fun matches (prog:Fixture.PROGRAM) * Small helper for finding instance types by name. *) -fun instanceTy (prog:Fixture.PROGRAM) +fun instanceTy (rootRib:RIB) (n:NAME) : TYPE = - case Fixture.getFixture (Fixture.getRootRib prog) (PropName n) of + case Fixture.getFixture rootRib (PropName n) of (ClassFixture c) => ClassType c | (InterfaceFixture i) => InterfaceType i | _ => error [LogErr.name n, " does not resolve to an instance type"] -fun groundType (prog:Fixture.PROGRAM) +fun groundType (rootRib:RIB) (ty:TYPE) : TYPE = let (* FIXME: it is *super wrong* to just be using the root rib here. *) - val norm = normalize [Fixture.getRootRib prog] ty + val norm = normalize [rootRib] ty in norm end @@ -995,10 +995,10 @@ fun isGroundType (ty:TYPE) : bool = true fun groundExpr (ty:TYPE) (* or "groundType" *) : TYPE = ty (* FIXME: remove *) -fun getNamedGroundType (prog:Fixture.PROGRAM) +fun getNamedGroundType (rootRib:RIB) (name:NAME) : TYPE = - groundType prog (Name.typename name) + groundType rootRib (Name.typename name) end diff --git a/verify.sml b/verify.sml index 62b4145e..2e640d4e 100644 --- a/verify.sml +++ b/verify.sml @@ -57,26 +57,26 @@ type STD_TYPES = { type ENV = { returnType: Ast.TYPE option, strict: bool, - prog: Fixture.PROGRAM, + rootRib: Ast.RIB, ribs: Ast.RIBS, stdTypes: STD_TYPES } -fun withReturnType { returnType=_, strict, prog, ribs, stdTypes } returnType = - { returnType=returnType, strict=strict, prog=prog, ribs=ribs, stdTypes=stdTypes } +fun withReturnType { returnType=_, strict, rootRib, ribs, stdTypes } returnType = + { returnType=returnType, strict=strict, rootRib=rootRib, ribs=ribs, stdTypes=stdTypes } -fun withRibs { returnType, strict, prog, ribs=_, stdTypes } ribs = - { returnType=returnType, strict=strict, prog=prog, ribs=ribs, stdTypes=stdTypes } +fun withRibs { returnType, strict, rootRib, ribs=_, stdTypes } ribs = + { returnType=returnType, strict=strict, rootRib=rootRib, ribs=ribs, stdTypes=stdTypes } -fun withStrict { returnType, strict=_, prog, ribs, stdTypes } strict = - { returnType=returnType, strict=strict, prog=prog, ribs=ribs, stdTypes=stdTypes } +fun withStrict { returnType, strict=_, rootRib, ribs, stdTypes } strict = + { returnType=returnType, strict=strict, rootRib=rootRib, ribs=ribs, stdTypes=stdTypes } -fun withRib { returnType, strict, prog, ribs, stdTypes} extn = - { returnType=returnType, strict=strict, prog=prog, ribs=(extn :: ribs), stdTypes=stdTypes } +fun withRib { returnType, strict, rootRib, ribs, stdTypes} extn = + { returnType=returnType, strict=strict, rootRib=rootRib, ribs=(extn :: ribs), stdTypes=stdTypes } -fun withRibOpt { returnType, strict, prog, ribs, stdTypes} extn = +fun withRibOpt { returnType, strict, rootRib, ribs, stdTypes} extn = { returnType=returnType, strict=strict, - prog=prog, + rootRib=rootRib, ribs=case extn of NONE => ribs | SOME e => (e :: ribs), @@ -117,32 +117,32 @@ val undefinedType = Ast.UndefinedType val nullType = Ast.NullType val anyType = Ast.AnyType -fun newEnv (prog:Fixture.PROGRAM) +fun newEnv (rootRib:Ast.RIB) (strict:bool) : ENV = { returnType = NONE, strict = strict, - prog = prog, - ribs = [Fixture.getRootRib prog], + rootRib = rootRib, + ribs = [rootRib], stdTypes = { - AnyNumberType = Type.getNamedGroundType prog Name.ES4_AnyNumber, - doubleType = Type.getNamedGroundType prog Name.ES4_double, - decimalType = Type.getNamedGroundType prog Name.ES4_decimal, + AnyNumberType = Type.getNamedGroundType rootRib Name.ES4_AnyNumber, + doubleType = Type.getNamedGroundType rootRib Name.ES4_double, + decimalType = Type.getNamedGroundType rootRib Name.ES4_decimal, - AnyStringType = Type.getNamedGroundType prog Name.ES4_AnyString, - stringType = Type.getNamedGroundType prog Name.ES4_string, + AnyStringType = Type.getNamedGroundType rootRib Name.ES4_AnyString, + stringType = Type.getNamedGroundType rootRib Name.ES4_string, - AnyBooleanType= Type.getNamedGroundType prog Name.ES4_AnyBoolean, - booleanType = Type.getNamedGroundType prog Name.ES4_boolean, + AnyBooleanType= Type.getNamedGroundType rootRib Name.ES4_AnyBoolean, + booleanType = Type.getNamedGroundType rootRib Name.ES4_boolean, - RegExpType = Type.getNamedGroundType prog Name.public_RegExp, + RegExpType = Type.getNamedGroundType rootRib Name.public_RegExp, - NamespaceType = Type.getNamedGroundType prog Name.ES4_Namespace, + NamespaceType = Type.getNamedGroundType rootRib Name.ES4_Namespace, - TypeType = Type.getNamedGroundType prog Name.intrinsic_Type + TypeType = Type.getNamedGroundType rootRib Name.intrinsic_Type } } @@ -225,7 +225,7 @@ and verifyType (env:ENV) val _ = trace ["verifyType: calling normalize ", LogErr.ty ty] val norm : Ast.TYPE = (* FIXME: it is *super wrong* to just be using the root rib here. - Type.normalize [Fixture.getRootRib (#prog env)] ty *) + Type.normalize [(#rootRib env)] ty *) Type.normalize (#ribs env) ty handle LogErr.TypeError e => let in @@ -318,7 +318,7 @@ and verifyExpr2 (env:ENV) (expr:Ast.EXPRESSION) : Ast.TYPE = let - val { prog, + val { rootRib, strict, stdTypes = { AnyNumberType, @@ -747,7 +747,7 @@ and verifyStmt (env:ENV) : unit = let fun verifySub s = verifyStmt env s - val { prog, + val { rootRib, strict, returnType, stdTypes = @@ -1008,25 +1008,25 @@ and verifyFragment (env:ENV) Ast.Anon block => verifyBlock env block -and verifyTopRib (prog:Fixture.PROGRAM) +and verifyTopRib (rootRib:Ast.RIB) (strict:bool) (rib:Ast.RIB) : unit = let - val env = newEnv prog strict + val env = newEnv rootRib strict in verifyRib env rib end -and verifyTopFragment (prog:Fixture.PROGRAM) +and verifyTopFragment (rootRib:Ast.RIB) (strict:bool) (frag:Ast.FRAGMENT) : Ast.FRAGMENT = if strict then let - val env = newEnv prog strict + val env = newEnv rootRib strict in trace ["verifyTopFragment"]; if !doTraceFrag then