1(* Compiler.sml *)
2
3open List Obj BasicIO Nonstdio Fnlib Mixture Const Globals Location Units;
4open Types Smlperv Asynt Parser Ovlres Infixres Elab Sigmtch;
5open Tr_env Front Back Pr_zam Emit_phr;
6
7(* Lexer of stream *)
8
9fun createLexerStream (is : BasicIO.instream) =
10  Lexing.createLexer (fn buff => fn n => Nonstdio.buff_input is buff 0 n)
11;
12
13(* Parsing functions *)
14
15fun parsePhrase parsingFun lexingFun lexbuf =
16  let fun skip() =
17    (case lexingFun lexbuf of
18        EOF => ()
19      | SEMICOLON => ()
20      | _ => skip())
21    handle LexicalError(_,_,_) =>
22      skip()
23  in
24    parsingFun lexingFun lexbuf
25    handle
26        Parsing.ParseError f =>
27           let val pos1 = Lexing.getLexemeStart lexbuf
28               val pos2 = Lexing.getLexemeEnd lexbuf
29           in
30             Lexer.resetLexerState();
31             if f (Obj.repr EOF) orelse
32                f (Obj.repr SEMICOLON)
33             then () else skip();
34             msgIBlock 0;
35             errLocation (Loc(pos1, pos2));
36             errPrompt "Syntax error.";
37             msgEOL();
38             msgEBlock();
39             raise Toplevel
40           end
41       | LexicalError(msg, pos1, pos2) =>
42           (msgIBlock 0;
43            if pos1 >= 0 andalso pos2 >= 0 then
44              errLocation (Loc(pos1, pos2))
45            else ();
46            errPrompt "Lexical error: "; msgString msg;
47            msgString "."; msgEOL();
48            msgEBlock();
49            skip();
50            raise Toplevel)
51       | Toplevel =>
52           (skip ();
53            raise Toplevel)
54  end
55;
56
57fun parsePhraseAndClear parsingFun lexingFun lexbuf =
58  let val phr =
59    parsePhrase parsingFun lexingFun lexbuf
60    handle x => (Lexer.resetLexerState(); Parsing.clearParser(); raise x)
61  in
62    Lexer.resetLexerState();
63    Parsing.clearParser();
64    phr
65  end;
66
67val parseToplevelPhrase =
68  parsePhraseAndClear Parser.ToplevelPhrase Lexer.Token
69;
70
71val parseStructFile = fn umode => fn lexbuff =>
72    case umode of
73      STRmode =>
74	    parsePhraseAndClear Parser.StructFile Lexer.Token lexbuff
75    | TOPDECmode =>
76	    parsePhraseAndClear Parser.TopDecFile Lexer.Token lexbuff
77;
78
79val parseSigFile = fn umode => fn lexbuff =>
80    case umode of
81      STRmode =>
82	  parsePhraseAndClear Parser.SigFile Lexer.Token lexbuff
83    | TOPDECmode =>
84	  parsePhraseAndClear Parser.TopSpecFile Lexer.Token lexbuff
85;
86
87fun isInTable key tbl =
88  (Hasht.find tbl key; true)
89  handle Subscript => false
90;
91
92fun filter p xs =
93  rev(foldL (fn x => fn acc => if p x then x::acc else acc) [] xs)
94;
95
96fun filterExcRenList excRenList uVarEnv =
97  filter (fn ({qual, id = id}, _) => isInTable (longIdentAsIdent id "filterExnRenList") uVarEnv) excRenList
98;
99
100fun filterValRenList valRenList uModEnv uFunEnv uVarEnv =
101    filter (fn (id, stamp) =>
102	    case unmangle id of
103		 ValId vid => isInTable vid uVarEnv
104	      |  ModId mid => isInTable mid uModEnv
105	      |  FunId fid => isInTable fid uFunEnv)
106    valRenList
107;
108
109fun cleanEnvAcc [] acc = acc
110  | cleanEnvAcc ((k, v) :: rest) acc =
111      if exists (fn (k', _) => k = k') acc then
112        cleanEnvAcc rest acc
113      else
114        cleanEnvAcc rest ((k, v) :: acc)
115;
116
117fun cleanEnv env =
118  cleanEnvAcc (foldEnv (fn a => fn x => fn acc => (a,x)::acc) [] env) []
119;
120
121
122(* Reporting the results of compiling a phrase *)
123
124val verbose = ref false;
125
126
127
128fun reportFixityResult (id, status) =
129(
130  (case status of
131       NONFIXst =>
132         msgString "nonfix "
133     | INFIXst i =>
134         (msgString "infix ";
135          msgInt i; msgString " ")
136     | INFIXRst i =>
137         (msgString "infixr ";
138          msgInt i; msgString " "));
139  msgString id
140);
141
142
143fun reportEquOfType equ =
144  msgString
145    (case equ of
146         FALSEequ => ""
147       | TRUEequ => "eq"
148       | REFequ => "prim_EQ"
149       | _ => fatalError "reportEquOfType")
150;
151
152fun reportLhsOfTypeResult (tyname : TyName) =
153  let val arity = case (#tnKind (!(#info tyname))) of
154                    ARITYkind arity => arity
155                  | _ => fatalError "reportLhsOfTypeResult"
156      val vs = newTypeVars arity
157      val lhs = type_con (map TypeOfTypeVar vs) tyname
158  in printType lhs end
159;
160
161fun reportTypeResult tyname =
162    (msgString "toplevel reportTypeResult disabled";
163    msgFlush())
164
165local
166    fun prTopEnv prInfo env firstLine =
167	foldEnv (fn k => fn v => fn firstLine =>
168		(msgIBlock 0;
169		 prInfo k v;
170                 msgEOL();
171                 msgEBlock();
172		 false)) firstLine env;
173   fun prVal {qualid,info=(sch,status)} = ()
174in
175fun report_comp_results iBas (Env as EXISTS(T,(ME,FE,GE,VE,TE))) =
176  let
177     val _ = checkClosedExEnvironment Env;
178     val _ = collectTopVars Env;
179     val firstLine =
180	 case T of
181	     [] => true
182	   |   _ =>  (msgIBlock 0;
183		      msgPrompt "New type names: ";
184		      prTyNameSet T ",";
185		      msgEOL();
186		      msgEBlock();
187		      false)
188     val firstLine =
189	 prTopEnv (fn id => fn status => reportFixityResult (id,status)) iBas firstLine;
190     val firstLine =
191	 prTopEnv prModInfo ME firstLine;
192     val firstLine =
193	 prTopEnv prFunInfo FE firstLine;
194     val firstLine =
195	 prTopEnv prSigInfo GE firstLine;
196     val firstLine =
197	 prTopEnv prTyInfo TE firstLine;
198     val firstLine =
199         prTopEnv (prVarInfo prVal) VE firstLine
200  in
201      ()
202  end
203end;
204
205(* To write the signature of the unit currently compiled *)
206(* The same value has to be written twice, because it's unclear *)
207(* how to `open` a file in "read/write" mode in a Caml Light program. *)
208
209fun writeCompiledSignature filename_ui =
210  let val sigStamp = ref dummySigStamp
211      val sigLen = ref 0
212  in
213    let val os = open_out_bin filename_ui in
214      (output_value os (!currentSig);
215       sigLen := pos_out os;
216       close_out os)
217      handle x =>
218        (close_out os;
219         remove_file filename_ui;
220         raise x)
221    end;
222    let val is = open_in_bin filename_ui in
223      let val sigImage = input(is, !sigLen)
224	  prim_val md5sum_ : string -> string = 1 "md5sum"
225      in
226        if size sigImage < !sigLen then raise Size else ();
227        close_in is;
228        remove_file filename_ui;
229        sigStamp := md5sum_ sigImage
230      end
231      handle x =>
232        (close_in is;
233         remove_file filename_ui;
234         raise x)
235    end;
236    let val os = open_out_bin filename_ui in
237      (output(os, !sigStamp);
238       output_value os (!currentSig);
239       close_out os)
240      handle x =>
241        (close_out os;
242         remove_file filename_ui;
243         raise x)
244    end;
245    !sigStamp
246  end;
247
248(* Checks and error messages for compiling units *)
249
250fun checkUnitId msg (locid as (loc, id)) uname =
251    if (Config.normalizedUnitName id) <> uname then
252	(msgIBlock 0;
253	 errLocation loc;
254	 errPrompt "Error: "; msgString msg;
255	 msgString " name and file name are incompatible";
256	 msgEOL();
257	 msgEBlock();
258	 raise Toplevel)
259    else ();
260
261(* Check that there is a .ui file in the load_path: *)
262
263fun checkExists filename_ui filename_sig filename_sml =
264    (find_in_path filename_ui; ())
265    handle Fail _ =>
266	(msgIBlock 0;
267	 errPrompt "File "; msgString filename_sig;
268	 msgString " must be compiled before ";
269	 msgString filename_sml; msgEOL();
270	 msgEBlock();
271	 raise Toplevel)
272
273fun checkNotExists filename_sig filename_sml =
274    if file_exists filename_sig then
275	(msgIBlock 0;
276	 errPrompt "File "; msgString filename_sig;
277	 msgString " exists, but there is no signature constraint in ";
278	 msgString filename_sml; msgEOL();
279	 msgEBlock();
280	 raise Toplevel)
281    else ();
282
283(* Compiling a signature *)
284
285(* cvr: TODO this could be optimized by using checkNoRebindings,
286   and just calling the update functions instead of extendXXX, which
287   are then made redundant *)
288fun compileSigExp sigexp =
289  let
290      val sigexp = resolveToplevelSigExp sigexp
291      val LAMBDA(T, RS) = elabToplevelSigExp sigexp
292  in
293    incrBindingLevel();
294    refreshTyNameSet PARAMETERts T;
295    updateCurrentStaticT T;
296    (strOptOfSig (!currentSig)) := SOME RS;
297    let val S' = normStr (SofRecStr RS)  (* cvr: we norm S so that calculated (sub)fields
298					  are correct *)
299    in
300	extendCurrentStaticME (MEofStr S');
301	extendCurrentStaticFE (FEofStr S');
302	extendCurrentStaticGE (GEofStr S');  (* should actually be empty ... *)
303	extendCurrentStaticVE (VEofStr S');
304	extendCurrentStaticTE (TEofStr S')
305    end;
306    if !verbose then
307      ((* report_comp_results iBas cBas VE TE; *) (*cvr: TODO*)
308       msgFlush())
309    else ()
310  end
311;
312
313fun compileSpecPhrase elab spec =
314  let
315      val (iBas,spec) = resolveToplevelSpec spec
316      val LAMBDA(T, S) = elab spec
317  in
318    incrBindingLevel();
319    refreshTyNameSet PARAMETERts T;
320    updateCurrentStaticT T;
321    extendCurrentStaticIBas iBas;
322    extendCurrentStaticS S;
323    let val S' = normStr S  (* cvr: we norm S so that calculated (sub)fields
324			       are correct *)
325    in
326	extendCurrentStaticME (MEofStr S');
327	extendCurrentStaticFE (FEofStr S');
328	extendCurrentStaticGE (GEofStr S');
329	extendCurrentStaticVE (VEofStr S');
330	extendCurrentStaticTE (TEofStr S')
331    end;
332    if !verbose then
333      ((* report_comp_results iBas cBas VE TE; *) (*cvr: TODO*)
334       msgFlush())
335    else ()
336  end
337;
338
339fun compileSignature context uname umode filename =
340  let
341      val source_name = filename ^ ".sig"
342      val target_name = filename ^ ".ui"
343      (* val () = (msgIBlock 0;
344                   msgString "[compiling file \""; msgString source_name;
345                   msgString "\"]"; msgEOL(); msgEBlock();) *)
346      val () = startCompilingUnit uname "" umode
347      val () = initInitialEnvironments context
348      val () = resetTypes ();
349      val is = open_in_bin source_name
350      val () = remove_file target_name;
351      val lexbuf = createLexerStream is
352      fun removeGEofSig () =
353	  case (strOptOfSig(!currentSig)) of
354	      ref NONE => ()
355	    | r as (ref (SOME RS)) => r := SOME (removeGEofRecStr RS)
356      fun compileSig (AnonSig specs) =
357	  (* cvr: TODO warn *)
358	  (app (compileSpecPhrase elabSigSpec) specs;
359	   (#uIdent(!currentSig)):= uname;
360	   Hasht.clear (iBasOfSig(!currentSig));
361	   Hasht.clear (sigEnvOfSig(!currentSig));
362	   removeGEofSig()
363	   )
364	| compileSig (NamedSig{locsigid as (_,sigid), sigexp}) =
365	  (checkUnitId "signature" locsigid uname;
366	   compileSigExp sigexp;
367	   (#uIdent(!currentSig)):= sigid;
368	   Hasht.clear (iBasOfSig(!currentSig));
369	   Hasht.clear (sigEnvOfSig(!currentSig));
370	   removeGEofSig())
371        | compileSig (TopSpecs specs) =
372	   app (compileSpecPhrase elabToplevelSpec) specs
373  in
374       input_name   := source_name;
375       input_stream := is;
376       input_lexbuf := lexbuf;
377       extendCurrentStaticS (STRstr(NILenv,NILenv,NILenv,NILenv,NILenv));
378         (* cvr: need the above  to distinguish
379	         an empty sig file
380                 from a non-existent one *)
381       (compileSig (parseSigFile umode lexbuf);
382        ignore (rectifySignature ());
383        ignore (writeCompiledSignature target_name);
384        close_in is)
385       handle x => (close_in is;raise x)
386  end
387;
388
389(* Compiling an implementation *)
390
391(* This is written in tail-recursive form to ensure *)
392(* that the intermediate results will be discarded. *)
393
394fun updateCurrentCompState ((iBas, ExEnv as EXISTS(T,(ME,FE,GE,VE, TE))), RE) =
395( updateCurrentInfixBasis iBas;
396  incrBindingLevel();
397  refreshTyNameSet PARAMETERts T;
398  updateCurrentStaticT T;
399  updateCurrentStaticME ME;
400  updateCurrentStaticFE FE;
401  updateCurrentStaticGE GE;
402  updateCurrentStaticVE VE;
403  updateCurrentStaticTE TE;
404  updateCurrentRenEnv RE;
405  if !verbose then
406    (report_comp_results iBas ExEnv;
407     msgFlush())
408  else ()
409);
410
411fun compLamPhrase os state (RE, lams) =
412(
413  app
414    (fn (is_pure, lam) =>
415       ((* msgIBlock 0; Pr_lam.printLam lam; msgEOL(); msgEBlock(); *)
416       emit_phrase os
417         let val zam = compileLambda is_pure lam in
418           (* printZamPhrase zam; msgFlush(); *)
419           zam
420         end))
421    lams;
422    updateCurrentCompState (state, RE)
423);
424
425fun compResolvedDecPhrase os elab (iBas, dec) =
426  let val ExEnv = elab dec in
427    resolveOvlDec dec;
428    commit_free_typevar_names (); (* cvr: will never be rolled-back *)
429    compLamPhrase os (iBas, ExEnv) (translateToplevelDec dec)
430  end
431;
432
433fun compileImplPhrase os elab dec =
434  let val (iBas,resdec) = resolveToplevelDec dec in
435      compResolvedDecPhrase os elab (iBas,resdec)
436  end
437;
438
439fun compileAndEmit context uname uident umode filename specSig_opt elab decs =
440  let
441    val filename_ui  = filename ^ ".ui"
442    val filename_uo  = filename ^ ".uo"
443    (* val () = (msgIBlock 0;
444                 msgString "[compiling file \""; msgString filename_sml;
445                 msgString "\"]"; msgEOL(); msgEBlock()) *)
446    val () = startCompilingUnit uname uident umode
447    val () = initInitialEnvironments context
448    val () = extendInitialSigEnv specSig_opt
449             (* if in STRmode and the optional sig is there
450                then we add the signature to the environment of the body *)
451    val () = resetTypes();
452    val os = open_out_bin filename_uo
453  in
454    ( start_emit_phrase os;
455      app (compileImplPhrase os elab) decs;
456      (case umode of
457	 STRmode =>
458	     (Hasht.clear (iBasOfSig(!currentSig));
459	      Hasht.clear (sigEnvOfSig(!currentSig)))
460       | TOPDECmode => ());
461      let val (excRenList, valRenList) = rectifySignature() in
462          (case specSig_opt of
463               NONE =>
464                (checkClosedCSig (!currentSig);
465                 let val sigStamp = writeCompiledSignature filename_ui in
466                   end_emit_phrase
467                     excRenList valRenList
468                     sigStamp (#uMentions (!currentSig))
469                     os
470                 end)
471             | SOME specSig =>
472                 let val {uVarEnv,uModEnv,uFunEnv,uStamp, ...} = specSig
473                     val valRenList = matchSignature os valRenList (!currentSig) specSig;
474		 in
475                   end_emit_phrase
476                     (filterExcRenList excRenList uVarEnv)
477                     (filterValRenList valRenList uModEnv uFunEnv uVarEnv)
478                     (getOption (!uStamp)) (#uMentions (!currentSig))
479                     os
480                 end);
481          close_out os
482        end
483    )
484    handle x => (close_out os; remove_file filename_uo;raise x)
485  end;
486
487(* cvr: TODO
488        match modes *before* compiling, to catch this error early on
489	warn on deprecated syntax
490*)
491
492fun compileUnitBody context uname umode filename =
493  let val filename_sig = filename ^ ".sig"
494      val filename_ui  = filename ^ ".ui"
495      val filename_sml = filename ^ ".sml"
496      val is = open_in_bin filename_sml
497      val lexbuf = createLexerStream is
498      fun compileStruct (AnonStruct decs) =
499	  (* cvr: TODO warn *)
500	  if file_exists filename_sig then
501	      (checkExists filename_ui filename_sig filename_sml;
502	       compileAndEmit context uname uname umode filename (SOME (readSig uname)) elabStrDec decs)
503	  else
504	      (remove_file filename_ui;
505	       compileAndEmit context uname uname umode filename NONE elabStrDec decs)
506	| compileStruct (NamedStruct{locstrid as (_,strid), locsigid = NONE, decs}) =
507	  (checkUnitId "structure" locstrid uname;
508	   checkNotExists filename_sig filename_sml;
509	   remove_file filename_ui;
510	   compileAndEmit context uname strid umode filename NONE elabStrDec decs)
511	 (* cvr: TODO remove locsigid field from NamedStruct *)
512	| compileStruct (NamedStruct _) = fatalError "compileUnitBody"
513	| compileStruct (Abstraction{locstrid as (_,strid), locsigid, decs}) =
514	  (checkUnitId "structure" locstrid uname;
515	   checkUnitId "signature" locsigid uname;
516	   checkExists filename_ui filename_sig filename_sml;
517	   compileAndEmit context uname strid umode filename (SOME (readSig uname)) elabStrDec decs
518)
519	| compileStruct (TopDecs decs) =
520	  if file_exists filename_sig then
521	      (checkExists filename_ui filename_sig filename_sml;
522	       compileAndEmit context uname "" umode  filename (SOME (readSig uname)) elabToplevelDec decs)
523	  else
524	      (remove_file filename_ui;
525	       compileAndEmit context uname "" umode filename NONE elabToplevelDec decs)
526  in
527      input_name := filename_sml;
528      input_stream := is;
529      input_lexbuf := lexbuf;
530      (compileStruct (parseStructFile umode lexbuf))
531       handle x => (close_in is; raise x)
532  end;
533
534
535
536
537
538
539