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