![[BACK]](/cvsweb/icons/back.gif){kind=icon}
Return to process.sml CVS log ![[TXT]](/cvsweb/icons/text.gif){kind=icon}
![[DIR]](/cvsweb/icons/dir.gif){kind=icon}
Up to [Research Unix] / researchv10no / cmd / sml / src / build|
Return to process.sml CVS log | Up to [Research Unix] / researchv10no / cmd / sml / src / build |
1.1 root 1: (* Copyright 1989 by AT&T Bell Laboratories *)
2: signature PROCESSFILE =
3: sig
4: exception Stop
5: val dumpMap : unit -> unit
6: val prLambda : unit -> unit
7: val prFun : int -> unit
8: val printslots : string -> unit
9: val timemsg : string -> bool
10: val process : string * (Lambda.lexp * string -> unit) option -> unit
11: val load : string -> unit
12: val reset : unit -> unit
13: val primeEnv : unit -> unit
14: val getCore : unit -> int list
15: val bootEnv : (string -> unit) -> int * int * int
16: end
17:
18: structure ProcessFile : PROCESSFILE =
19: struct
20:
21: open Access Basics PrintUtil EnvAccess
22:
23: exception Stop
24:
25: fun timemsg (s : string) =
26: if !System.Control.timings then (print s; newline(); true) else false
27:
28: val saveLambda = System.Control.saveLambda
29: val lambda = ref (Lambda.RECORD [])
30: (* really needed only for interactive version *)
31: val _ = System.Control.prLambda := fn () => (MCprint.printLexp (!lambda); newline())
32: fun prLambda() = (MCprint.printLexp(!lambda); newline())
33: fun prFun lv = (MCprint.printFun(!lambda) lv; newline())
34:
35:
36: (* debugging aid--print the slots of a structure
37: -- this belongs somewhere else *)
38:
39: fun printslot {name,access=SLOT s} =
40: (print "Slot "; print s; print " : ";
41: print(Symbol.name name);
42: print "\n")
43: | printslot {name,access=LVAR s} =
44: (print "Lvar "; print s; print " : ";
45: print(Symbol.name name);
46: print "\n")
47: | printslot {name,access=INLINE s} =
48: (print "Inline "; print(Prim.inLineName s); print " : ";
49: print(Symbol.name name);
50: print "\n")
51: | printslot {name,access=PATH _} =
52: (print "Path?? :";
53: print(Symbol.name name);
54: print "\n")
55:
56: val usl : {name:Symbol.symbol,access:access} list ref = ref nil
57:
58: fun buildlist (_,_,VARbind(VALvar{name=[n],access,...})) =
59: usl := {name=n,access=access} :: !usl
60: | buildlist (_,_,STRbind(STRvar{name=[n],access,...})) =
61: usl := {name=n,access=access} :: !usl
62: | buildlist (_,_,CONbind(DATACON{name,rep=(VARIABLE access),...})) =
63: usl := {name=name,access=access} :: !usl
64: | buildlist _ = ()
65:
66: fun slotgt ({access=SLOT s1,name},{access=SLOT s2,name=_}) = s1 > s2
67: | slotgt ({access=SLOT _,...},_) = true
68: | slotgt ({access=LVAR v1,...},{access=LVAR v2,...}) = v1 > v2
69: | slotgt ({access=LVAR _,...},_) = true
70: | slotgt ({access=INLINE i1,...},{access=INLINE i2,...}) =
71: ErrorMsg.impossible "why do you sort slots" (* i1 > i2 *)
72: | slotgt ({access=INLINE _,...},_) = true
73: | slotgt _ = ErrorMsg.impossible "Path access in printslots"
74:
75: fun symPath s =
76: let fun f nil = (nil,nil)
77: | f ("."::m) =
78: let val (s,syms) = f m
79: in (nil,Symbol.symbol(implode s)::syms)
80: end
81: | f (a::m) =
82: let val (s,syms) = f m
83: in (a::s,syms)
84: end
85: val (s,syms) = f(explode s)
86: in Symbol.symbol(implode s)::syms
87: end
88:
89: fun qid symlist =
90: let fun getStr([],str) = str
91: | getStr(id::rest,STRstr{table,env,...}) =
92: let val STRvar{access=SLOT n,binding,...} =
93: lookSTRinTable(table,id)
94: handle Env.UnboundTable =>
95: (print ("unbound intermediate structure in path: "
96: ^ Symbol.name id ^ "\n"); raise Stop)
97: val str = case (binding,env)
98: of (INDstr i,REL{s,...}) => s sub i
99: | (SHRstr(i::r),REL{s,...}) =>
100: TypesUtil.getEpath(r,s sub i)
101: | (STRstr _, _) => binding
102: | _ => ErrorMsg.impossible "Process.qid.getStr"
103: in getStr(rest,str)
104: end
105: val firstId::rest = symPath symlist
106: val STRvar{binding,...} = lookSTR firstId
107: handle Unbound => (print("unbound structure at head of path: "
108: ^ Symbol.name firstId ^ "\n"); raise Stop)
109: in getStr(rest,binding)
110: end
111:
112: fun printslots s =
113: let val STRstr{table,...} = qid s
114: val unsortedlist = (usl := nil; IntStrMap.app buildlist table; !usl)
115: val sortedlist = Sort.sort slotgt unsortedlist
116: in print "module "; print s; print "\n";
117: app printslot sortedlist
118: end
119: handle Bind => ErrorMsg.impossible "Weird structure in printslots"
120:
121:
122: open ErrorMsg BareAbsyn Lambda System.Timer
123:
124: fun for l f = app f l
125: val update = System.Stats.update
126: val printDepth = System.Control.Print.printDepth
127:
128: fun opt lam =
129: let val timer = start_timer()
130: val lam = if !CGoptions.reduce then Opt.reduce lam else lam
131: val _ = if !anyErrors then raise Stop else ()
132: val lam = if !CGoptions.hoist then Opt.hoist lam else lam
133: val time = check_timer timer
134: in update(System.Stats.codeopt,time);
135: timemsg("codeopt, " ^ makestring time ^ "s")
136: orelse debugmsg "codeopt";
137: if !anyErrors then raise Stop else ();
138: lam
139: end
140:
141: fun parse (lex: Lex.lexer) =
142: let val ref linenum = ErrorMsg.lineNum
143: val timer = start_timer()
144: val _ = debugmsg "about to parse"
145: val _ = while !(#nextToken lex) = Token.SEMICOLON
146: do (#advance lex)();
147: val absyn = (anyErrors := false; Parse.interdec lex)
148: val time = check_timer timer
149: val lines = !ErrorMsg.lineNum - linenum
150: in update(System.Stats.parse,time);
151: System.Stats.lines := !System.Stats.lines + lines;
152: timemsg("parse, " ^ Integer.makestring lines
153: ^ " lines, " ^ makestring time ^ "s")
154: orelse debugmsg "parse completed";
155: if !anyErrors then raise Stop else ();
156: absyn
157: end
158:
159: fun transStrb sb =
160: let val timer = start_timer()
161: val (sb,profil) = Prof.instrumStrb sb
162: val Absyn.STRB{strvar=STRvar{access=LVAR v,...},...} = sb
163: val lam = Translate.transDec (Absyn.STRdec[sb]) (Lambda.VAR v)
164: val lam = Prof.bindLambda(lam,profil)
165: val time = check_timer timer
166: in update(System.Stats.translate,time);
167: timemsg("translate, " ^ makestring time ^ "s")
168: orelse debugmsg "translate";
169: if !anyErrors then raise Stop else ();
170: lam
171: end
172:
173: fun transFctb fb =
174: let val timer = start_timer()
175: val (fb,profil) = Prof.instrumFctb fb
176: val Absyn.FCTB{fctvar=FCTvar{access=LVAR v,...},...} = fb
177: val lam = Translate.transDec (Absyn.FCTdec[fb]) (Lambda.VAR v)
178: val lam = Prof.bindLambda(lam,profil)
179: val time = check_timer timer
180: in update(System.Stats.translate,time);
181: timemsg("translate, " ^ makestring time ^ "s")
182: orelse debugmsg "translate";
183: if !anyErrors then raise Stop else ();
184: lam
185: end
186:
187: (* lvar -> string environment used by batch compiler to map module
188: lvars to names of modules *)
189: exception Modname
190: val m : string Intmap.intmap = Intmap.new(32, Modname)
191: val lookup = Intmap.map m
192: val enterName = Intmap.add m
193: fun lookupName v =
194: lookup v
195: handle Modname =>
196: let val s = Access.lvarName v
197: in ErrorMsg.complain ("Bad free variable: " ^ Access.lvarName v);
198: s
199: end
200: fun dumpMap() =
201: let fun p(i:int,s:string) = (print i; print " -> "; print s; print "\n")
202: in print "lvar -> structure mapping:\n"; Intmap.app p m
203: end
204:
205: val is_core = ref false;
206:
207: fun getCore () = if !is_core then [] else tl(!CoreInfo.stringequalPath)
208:
209: fun process(fname, gencode) =
210: let val stream = open_in fname
211: val lex = Lex.mkLex{stream=stream, interactive=false}
212: val _ = (ErrorMsg.fileName := fname; ErrorMsg.lineNum := 1;
213: System.interactive := false)
214: val _ = Env.commit()
215: fun cleanup() = (print("[closing " ^ fname ^ "]\n");
216: close_in stream)
217: fun proc(name,lvar,mkLam) =
218: (enterName(lvar, name);
219: case gencode of
220: NONE => ()
221: | SOME gencode =>
222: let val lam = Opt.closestr(lookupName,opt(mkLam()), getCore())
223: in debugmsg "closed";
224: if !saveLambda then lambda := lam else ();
225: gencode(lam, name);
226: if !anyErrors then raise Stop else ()
227: end)
228: fun loop() =
229: let val absyn = parse lex
230: in case absyn
231: of SIGdec _ =>
232: (PrintAbsyn.printDec(absyn,0,!printDepth);
233: newline())
234: | OPENdec _ =>
235: (PrintAbsyn.printDec(absyn,0,!printDepth);
236: newline())
237: | STRdec sbs =>
238: for sbs
239: (fn sb as
240: STRB{strvar=STRvar{name=[n],access=LVAR v,...},...} =>
241: (print "structure "; printSym n; newline();
242: let val mkLam = fn () => transStrb sb
243: in proc(Symbol.name n, v, mkLam)
244: end))
245: | ABSdec sbs =>
246: for sbs
247: (fn sb as
248: STRB{strvar=STRvar{name=[n],access=LVAR v,...},...} =>
249: (print "abstraction "; printSym n; newline();
250: let val mkLam = fn () => transStrb sb
251: in proc(Symbol.name n, v, mkLam)
252: end))
253: | FCTdec fbs =>
254: for fbs
255: (fn fb as
256: FCTB{fctvar=FCTvar{name,access=LVAR v,...},...} =>
257: (print "functor "; printSym name; newline();
258: let val mkLam = fn () => transFctb fb
259: in proc(Symbol.name name, v, mkLam)
260: end))
261: | _ => ErrorMsg.condemn "signature, functor, or structure expected";
262: loop()
263: end
264: in loop()
265: handle Parse.Eof =>
266: (cleanup();
267: if !anyErrors
268: then (Env.restore(); raise Stop)
269: else Env.consolidate())
270: | e => (Env.restore(); cleanup(); raise e)
271: end
272:
273: fun load fname = process(fname,NONE)
274:
275: (* initializing static environment *)
276:
277: (* priming structures: PrimTypes and InLine *)
278: val nameofPT = Symbol.symbol "PrimTypes"
279: val varofPT = STRvar{name=[nameofPT],access=LVAR 0,binding=Prim.primTypes}
280: val varofPT' = STRvar{name=[nameofPT],access=PATH[0],binding=Prim.primTypes}
281: val nameofIL = Symbol.symbol "InLine"
282: val varofIL = STRvar{name=[nameofIL],access=LVAR 0,binding=Prim.inLine}
283:
284: fun reset() =
285: (Env.reset();
286: EnvAccess.reset();
287: Typecheck.reset())
288:
289: fun primeEnv() =
290: (reset();
291: openStructureVar varofPT';
292: bindSTR(nameofPT,varofPT);
293: bindSTR(nameofIL,varofIL);
294: ())
295:
296: fun bootEnv (loader:string -> unit) =
297: (primeEnv();
298: load "boot/assembly.sig";
299: is_core := true;
300: (loader "boot/core.sml" handle e => (is_core := false; raise e));
301: is_core := false;
302: load "boot/dummy.sml";
303: let val svCore as STRvar{access=PATH[lvCore],...} =
304: lookSTR (Symbol.symbol "Core")
305: in CoreInfo.setCore(svCore);
306: load "boot/perv.sig";
307: load "boot/system.sig";
308: loader "boot/math.sml";
309: loader "boot/perv.sml";
310: load "boot/overloads.sml";
311: let val STRvar{access=PATH[lvMath],...} =
312: lookSTR (Symbol.symbol "Math")
313: and svInitial as STRvar{access=PATH[lvInitial],
314: binding=strInitial as STRstr{table,...},...} =
315: lookSTR (Symbol.symbol "Initial")
316: and STRvar{binding=STRstr{table=otable,...},...} =
317: lookSTR (Symbol.symbol "Overloads")
318: val sigs = map (fn s => lookSIG(Symbol.symbol s))
319: ["REF","LIST","ARRAY","BYTEARRAY","BASICIO",
320: "IO","BOOL","STRING","INTEGER","REAL","GENERAL"]
321: val NJsymbol = Symbol.symbol "NewJersey"
322: in Env.reset();
323: (* merge overload bindings into Initial's symtable *)
324: IntStrMap.app (IntStrMap.add table) otable;
325: openStructureVar(svInitial);
326: app (fn (sgn as SIGvar{name,...}) => bindSIG(name,sgn))
327: sigs;
328: bindSTR(NJsymbol, STRvar{name=[NJsymbol],access=LVAR(lvInitial),
329: binding=strInitial});
330: (lvCore,lvInitial,lvMath)
331: end
332: end)
333:
334: end (* structure ProcessFile *)
This archive runs on limited infrastructure. Preserving old code on modern bandwidth. Automated agents are requested to crawl responsibly.