1(* Exec_phr.sml *)
2open Const
3open List BasicIO Nonstdio Miscsys Fnlib Mixture Globals Units Types Asynt;
4open Infixst Ovlres Infixres Elab Pr_zam Tr_env Front Back Compiler;
5open Symtable Rtvals Load_phr;
6
7(* Will successful evaluation results be reported in the top-level system: *)
8
9val quietdec = ref false ;
10
11(* Executing a top-level declaration. *)
12
13local
14    fun prTopEnv prInfo env firstLine =
15	foldEnv (fn k => fn v => fn firstLine =>
16		(msgIBlock 0;
17		 (if firstLine then msgPrompt ""
18		  else msgContPrompt "");
19		 prInfo k v;
20                 msgEOL();
21                 msgEBlock();
22		 false)) firstLine env;
23   fun prVal {qualid,info=(sch,status)} =
24       let val qualid = if #qual qualid = ""
25			    then {qual = currentUnitName(), id = #id qualid} (* cvr: rectify on the fly *)
26			else qualid
27       in
28          msgString " ="; msgBreak(1, 4);
29	  (case status of
30	       VARname REGULARo  =>
31		 let val slot = get_slot_for_variable (lookupRenEnv ValId qualid)
32		     val v = getGlobalVal slot
33		 in
34		     printVal sch v
35		 end
36	     | VARname _ => msgString "(overloaded)"
37	     | PRIMname pi =>
38		 if #primArity pi  = 0 then
39		     msgString "-"
40		 else msgString "fn"
41	     | CONname ci =>
42		 if #conArity(!ci) = 0 then
43		     printVQ qualid
44		 else msgString "fn"
45	     | EXNname ei  =>
46		 if #exconArity(!ei) = 0 then
47		     printVQ qualid
48		 else msgString "fn"
49	     | REFname => msgString "fn");
50         msgBreak(0, 4)
51       end
52in
53fun report_results iBas (Env as EXISTS(T,(ME,FE,GE,VE,TE))) =
54  let
55     val _ = checkClosedExEnvironment Env;
56     val _ = collectTopVars Env;
57     val firstLine =
58	 case T of
59	     [] => true
60	   |   _ =>  (msgIBlock 0;
61		      msgPrompt "New type names: ";
62		      prTyNameSet T ",";
63		      msgEOL();
64		      msgEBlock();
65		      false)
66     val firstLine =
67	 prTopEnv (fn id => fn status => reportFixityResult (id,status)) iBas firstLine;
68     val firstLine =
69	 prTopEnv prModInfo ME firstLine;
70     val firstLine =
71	 prTopEnv prFunInfo FE firstLine;
72     val firstLine =
73	 prTopEnv prSigInfo GE firstLine;
74     val firstLine =
75	 prTopEnv prTyInfo TE firstLine;
76     val firstLine =
77         prTopEnv (prVarInfo prVal) VE firstLine
78  in
79      ()
80  end;
81end
82;
83
84
85
86(* This is written in tail-recursive form to ensure *)
87(* that the intermediate results will be discarded. *)
88
89fun updateCurrentState ((iBas, (Env as EXISTS(T,(ME,FE,GE,VE, TE)))), RE) =
90(
91  catch_interrupt false;
92  updateCurrentInfixBasis iBas;
93  updateCurrentStaticT T;
94  updateCurrentStaticME ME;
95  updateCurrentStaticFE FE;
96  updateCurrentStaticGE GE;
97  updateCurrentStaticTE TE;
98  updateCurrentStaticVE VE;
99  updateCurrentRenEnv RE;
100  catch_interrupt true;
101  if not (!quietdec) then
102      (report_results iBas Env;
103       msgFlush())
104  else ()
105);
106
107fun execLamPhrase state (RE, tlams) =
108(
109  app
110    (fn (is_pure, lam) =>
111      ( (* msgIBlock 0; Pr_lam.printLam lam; msgEOL(); msgEBlock();   *)
112        (* msgIBlock 0; Pr_lam.printLam lam; msgEOL(); msgEBlock();msgFlush(); *) (* cvr: TODO remove *)
113       ignore (loadZamPhrase
114         let val zam = compileLambda is_pure lam in
115             (* printZamPhrase zam; msgFlush(); *)
116	       zam
117         end)
118      ))
119    tlams;
120    updateCurrentState (state, RE)
121);
122
123fun execResolvedDecPhrase (iBas, dec) =
124
125  let (* val _ = Asyntfn.printDec dec (* cvr: *) *)
126      val ExEnv =
127	  let val ExEnv = elabToplevelDec dec
128          in
129              resolveOvlDec dec;
130              commit_free_typevar_names ();
131              ExEnv
132          end
133	  handle e => (rollback_free_typevar_names ();
134		       raise e)
135  in
136    execLamPhrase (iBas, ExEnv) (translateToplevelDec dec)
137  end
138;
139
140fun execToplevelPhrase dec =
141  let val _ = checkpoint_free_typevar_names ();
142      val (iBas,resdec) = resolveToplevelDec dec in
143    execResolvedDecPhrase (iBas,resdec)
144  end
145;
146
147
148
149
150
151
152
153
154
155
156
157
158
159
160
161