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