X-Git-Url: http://git.hcoop.net/hcoop/mlt.git/blobdiff_plain/b26ce3d96429d8721e85500d48d7dab2f97688e5..dcc38e493dadda082424e887a1e8f6397a9a5000:/src/compiler.sml

diff --git a/src/compiler.sml b/src/compiler.sml
index 0b6d484..cd03d6c 100644
--- a/src/compiler.sml
+++ b/src/compiler.sml
@@ -21,6 +21,8 @@
 
 structure Compiler :> COMPILER =
 struct
+    open Settings
+
     exception Error
 
     val cgiMode = Posix.FileSys.S.flags [Posix.FileSys.S.irwxu,
@@ -31,48 +33,14 @@ struct
 		    flush = fn () => TextIO.flushOut TextIO.stdOut,
 		    linewidth = 80}
 
-    fun getFname path =
-	let
-	    fun look i =
-		if i < 0 then
-		    path
-		else if String.sub (path, i) = #"/" then
-		    String.extract (path, i+1, NONE)
-		else
-		    look (i-1)
-	in
-	    look (size path - 1)
-	end
+    val getFname = OS.Path.file
 
-    fun removeExt path =
-	let
-	    val len = size path
-
-	    fun look i =
-		if i >= len then
-		    path
-		else if String.sub (path, i) = #"." then
-		    String.substring (path, 0, i)
-		else
-		    look (i+1)
-	in
-	    look 0
-	end
+    val removeExt = OS.Path.base
 
     fun getExt path =
-	let
-	    val len = size path
-
-	    fun look i =
-		if i >= len then
-		    path
-		else if String.sub (path, i) = #"." then
-		    String.extract (path, i+1, NONE)
-		else
-		    look (i+1)
-	in
-	    look 0
-	end
+	case OS.Path.ext path of
+	    NONE => path
+	  | SOME ext => ext
 
     val upperOffset = ord #"A" - ord #"a"
     fun toUpper ch =
@@ -112,8 +80,8 @@ struct
 
 	    fun loop (smls, mlts) =
 		(case Posix.FileSys.readdir dir of
-		     "" => (smls, mlts)
-		   | fname =>
+		     NONE => (smls, mlts)
+		   | SOME fname =>
 		     (case getExt fname of
 			  "mlt" => loop (smls, (path ^ "/" ^ fname) :: mlts)
 			| ("sml"|"sig") =>
@@ -141,7 +109,7 @@ struct
 	    val _ = TextIO.closeOut outf
 	    
 	    val outf = TextIO.openOut (outPath ^ "/.build.sml")
-	    val _ = TextIO.output (outf, "Control.quotation := true;\n")
+	    val _ = TextIO.output (outf, "Control.quotation := true;\nControl.printWarnings := false;\n")
 	    fun printMlts [] = ()
 	      | printMlts (h::t) =
 		(TextIO.output (outf, "\"" ^ h ^ "\"");
@@ -169,7 +137,6 @@ struct
 	    val outPath = Config.outPath config 
 	    val pubPath = Config.pubPath config
 	    val sml = Config.sml config
-	    val arch = "x86-linux"
 
 	    val loc = Environment.staticPart (#get (EnvRef.loc ()) ())
 	    val base = Environment.staticPart (#get (EnvRef.base ()) ())
@@ -241,6 +208,10 @@ struct
 	    val _ = TextIO.output (outf, "]\nend\n\nstructure Main = MainFn(Templates)\n")
 	    val _ = TextIO.closeOut outf
 
+	    val outf = TextIO.openOut (outPath ^ "/.build.sml")
+	    val _ = TextIO.output (outf, "Control.printWarnings := false;\nprint \"Here we go\"\n;\nCM.make \"sources.cm\";\nSMLofNJ.exportFn (\"" ^ outPath ^ "/heap\", Main.main);\n")
+	    val _ = TextIO.closeOut outf
+
 	    val outf = TextIO.openOut (outPath ^ "/sources.cm")
 	    val printNames = app (fn name => TextIO.output (outf, "\t" ^ name ^ "\n"))
 
@@ -268,7 +239,7 @@ struct
 		 printNames outputs;
 		 TextIO.output (outf, "\n\t(* Driver *)\n\n\t_main.sml\n");
 		 TextIO.closeOut outf;
-		 if OS.Process.system (sml ^ "/ml-build " ^ outPath ^ "/sources.cm Main.main " ^ outPath ^ "/heap") = OS.Process.success then
+		 if OS.Process.system ("cd " ^ outPath ^ " ; cat .build.sml | " ^ sml ^ "/sml") = OS.Process.success then
 		     (ListPair.app makeScript (scripts, exports);
 		      OS.Process.success)
 		 else