Execute as a script with mutecompiler

base/cm/main/cm-boot.sml

@@ -7,6 +7,9 @@
  * structure CM people find in $smlnj/cm/full.cm.
  *
  * author: Matthias Blume (blume@cs.princeton.edu)
+ *
+ * This module amended to include 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University
+ *
  *)
 
 functor LinkCM (structure HostBackend : BACKEND) = struct
@@ -690,7 +693,8 @@ functor LinkCM (structure HostBackend : BACKEND) = struct
 	  end
       end
   in
-    fun init (bootdir, de, er, useStream, useFile, errorwrap, icm) = let
+    (* New function useScriptFile included in the argument list as part of 'Execute as a script' change *)
+	fun init (bootdir, de, er, useStream, useScriptFile, useFile, errorwrap, icm) = let
 	fun procCmdLine () = let
 	    val autoload' = errorwrap (ignore o autoload mkStdSrcPath)
 	    val make' = errorwrap (ignore o makeStd)
@@ -701,6 +705,41 @@ functor LinkCM (structure HostBackend : BACKEND) = struct
 			"!* unable to process '", file, "' (unknown extension '", ext, "')\n"
 		      ]
 		  (* end case *))
+
+		  (* 'Execute as a script' change starts here. Change added by Dayanandan Natarajan *)
+			fun eatuntilnewline (instream : TextIO.instream): bool = let
+    			val c = TextIO.input1 instream
+  				in
+    				case TextIO.lookahead instream of
+          				SOME #"\n" => true
+        				| SOME c => eatuntilnewline instream
+        				| NONE => false
+  				end
+
+			fun checkSharpbang (instream : TextIO.instream): bool = let
+	    		val c = TextIO.input1 instream
+  				in
+   					case c of
+      					SOME #"#" => (
+        					case TextIO.lookahead instream of
+          						SOME #"!" => eatuntilnewline instream
+        						| SOME c => false
+        						| NONE => false
+        						)
+    					| SOME c => false
+    					| NONE => false
+  				end
+
+			fun processFileScript (fname) = let
+				val stream = TextIO.openIn fname
+  				val isscript = checkSharpbang stream
+				in
+				  	if (isscript) = false  
+  					then	( Say.say [ "!* Script file doesn't start with #!. \n" ] ) 
+					else	( useScriptFile (fname, stream) )
+				end
+			(* 'Execute as a script' change ends here *)
+
 	    fun inc n = n + 1
 	    fun show_controls (getarg, getval, padval) level = let
 		fun walk indent (ControlRegistry.RTree rt) = let
@@ -778,6 +817,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct
 		     \    <file>.cm        (CM.make or CM.autoload)\n\
 		     \    -m               (switch to CM.make)\n\
 		     \    -a               (switch to CM.autoload; default)\n\
+		     \    --script         (execute as a script)\n\
 		     \    <file>.sig       (use)\n\
 		     \    <file>.sml       (use)\n\
 		     \    <file>.fun       (use)\n\
@@ -878,6 +918,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct
 	      | args ("-S" :: _ :: _, mk) = (showcur NONE; nextarg mk)
 	      | args (["-E"], _) = (show_envvars NONE; quit ())
 	      | args ("-E" :: _ :: _, mk) = (show_envvars NONE; nextarg mk)
+	      | args ("--script" :: _, _) = (nextargscript ())  (* added as part of 'Execute as a script' change *)
 	      | args ("@CMbuild" :: rest, _) = mlbuild rest
 	      | args (["@CMredump", heapfile], _) = redump_heap heapfile
 	      | args (f :: rest, mk) =
@@ -890,6 +931,13 @@ functor LinkCM (structure HostBackend : BACKEND) = struct
 		let val l = SMLofNJ.getArgs ()
 		in SMLofNJ.shiftArgs (); args (l, mk)
 		end
+
+		(* nextargscript added as part of 'Execute as a script' change *)
+		and nextargscript () =
+		let val l = SMLofNJ.getArgs ()
+		in SMLofNJ.shiftArgs (); processFileScript (hd l); quit ()
+		end
+
 	in
 	    case SMLofNJ.getArgs () of
 		["@CMslave"] => (#set StdConfig.verbose false; slave ())

base/compiler/INDEX

@@ -271,6 +271,10 @@ MODULEUTIL
   ElabData/modules/moduleutil.sig
 ModuleUtil
   ElabData/modules/moduleutil.sml
+MUTECOMPILER
+  TopLevel/interact/mutecompiler.sig
+Mutecompiler
+  TopLevel/interact/mutecompiler.sml
 PARSER_CONTROL
   Parse/main/parsercontrol.sml
 ParserControl

base/compiler/MAP

@@ -623,6 +623,9 @@ TopLevel/
     interact.sig,sml
       creating top-level loops
       defs: INTERACT, Interact: EVALLOOP => INTERACT
+    mutecompiler.sig,sml
+      allow compiler silencing
+      defs: MUTECOMPILER, Mutecompiler
 
   print/
   Pretty printing for absyn declarations, values
@@ -770,4 +773,4 @@ SML stuff.
 
 3. MiscUtil was renamed Library, and has been simplified.  It now contains
 only three subdirectories, which can possibly be thought of as somewhat
-general purpose libraries.
+general purpose libraries.

base/compiler/TopLevel/backend/backend-fn.sml

@@ -92,4 +92,5 @@ functor BackendFn (
     structure Machine = M.Machine
     val architecture = M.architecture
     val abi_variant = M.abi_variant
+    structure Mutecompiler = Mutecompiler (* Added as part of 'Execute as a script' change done by Dayanandan Natarajan Heriot Watt University *)
 end

base/compiler/TopLevel/backend/backend.sig

@@ -6,6 +6,7 @@ signature BACKEND = sig
     structure Profile : PROFILE
     structure Compile : COMPILE
     structure Interact : INTERACT
+    structure Mutecompiler : MUTECOMPILER (* Added as part of 'Execute as a script' change done by Dayanandan Natarajan Heriot Watt University *)
     structure Machine : MACHINE
     val architecture: string
     val abi_variant: string option

base/compiler/TopLevel/interact/interact.sig

@@ -2,6 +2,9 @@
  *
  * COPYRIGHT (c) 2019 The Fellowship of SML/NJ (http://www.smlnj.org)
  * All rights reserved.
+ *
+ * This module amended to include 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University
+ *
  *)
 
 signature INTERACT =
@@ -27,6 +30,7 @@ signature INTERACT =
     val useFile : string -> bool
 
     val useStream : TextIO.instream -> unit
+    val useScriptFile : string * TextIO.instream -> unit (* Addded as part of Execute as a script change *)
     val evalStream : TextIO.instream * Environment.environment -> Environment.environment
 
     val withErrorHandling : bool -> (* true: treat all exns like usercode exns *)

base/compiler/TopLevel/interact/interact.sml

@@ -2,6 +2,9 @@
  *
  * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
  * All rights reserved.
+ *
+ * This module amended to include 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University
+ *
  *)
 
 functor Interact(EvalLoop : EVALLOOP) : INTERACT =
@@ -91,6 +94,20 @@ functor Interact(EvalLoop : EVALLOOP) : INTERACT =
 
     fun useStream stream = EvalLoop.evalStream ("<instream>", stream)
 
+    (* Function added as part of Execute as a script change*)
+    fun useScriptFile (fname, stream) = ( 
+       Mutecompiler.silenceCompiler () ;
+       EvalLoop.evalStream ("<instream>", (TextIO.openString "Backend.Mutecompiler.mcdummyfn ();") ) ; (* Idea from Dr Joe Wells HWU, to preload structure *)
+       Mutecompiler.unsilenceCompiler () ;
+
+       (EvalLoop.evalStream (fname, stream))
+         handle exn => ( 
+           Mutecompiler.printStashedCompilerOutput ();
+           Mutecompiler.unsilenceCompiler ();
+           EvalLoop.uncaughtExnMessage exn
+           )  
+      )
+
     fun evalStream (stream, baseEnv) = let
 	  val r = ref Environment.emptyEnv
 	  val base = { set = fn _ => raise Fail "evalStream: #set base",

base/compiler/TopLevel/interact/mutecompiler.sig

@@ -0,0 +1,31 @@
+(* mutecompiler.sig
+ *
+ * COPYRIGHT (c) 2019 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * This module introduced as part 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University 
+ * and functions derived from 'smlnj-script' developed by Dr Joe Wells, Heriot Watt University
+ *
+ *)
+
+signature MUTECOMPILER =
+  sig
+
+    val printlineLimit : int ref
+    val compilerMuted : bool ref
+    val isNewline : char -> bool
+    val push : 'a list ref -> 'a -> unit
+    val installPrintingLimitSettings : int list -> unit
+    val saveControlPrintOut : unit -> unit
+    val stashCompilerOutput : string -> unit
+    val savePrintingLimits : unit -> unit
+    val lowerPrintingLimitsToMin : unit -> unit
+    val restoreControlPrintOut : unit -> unit
+    val restorePrintingLimits : unit -> unit   
+    val outputFlush : TextIO.outstream -> TextIO.vector -> unit
+    val silenceCompiler : unit -> unit
+    val unsilenceCompiler : unit -> unit
+    val printStashedCompilerOutput : unit -> unit
+    val mcdummyfn : unit -> unit
+
+  end  (* signature MUTECOMPILER *)

base/compiler/TopLevel/interact/mutecompiler.sml

@@ -0,0 +1,146 @@
+(* mutecompiler.sml
+ *
+ * COPYRIGHT (c) 2017 The Fellowship of SML/NJ (http://www.smlnj.org)
+ * All rights reserved.
+ *
+ * This module introduced as part 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University 
+ * and functions derived from 'smlnj-script' developed by Dr Joe Wells, Heriot Watt University
+ *
+ *)
+
+structure Mutecompiler : MUTECOMPILER =
+  struct
+
+  (* compile and execute the contents of a file. *)
+  local    
+    val printingLimitRefs =
+          let open Control.Print
+          in [
+              printDepth, (* default: 5 , max 10 *)
+              printLength, (* default: 12 , max 16 *)
+              stringDepth, (* default: 70 *)
+              intinfDepth (* default: 70 *)
+              ]
+          end;
+
+    val savedControlPrintOut = ref NONE;
+
+    val savedPrintingLimitSettings = ref NONE;
+
+    val compilerOutputPreviousFullLines = ref ([] : string list);
+
+    val compilerOutputCurrentLine = ref ([] : string list);
+
+
+
+  in
+
+    val printlineLimit = ref 5;
+
+    val compilerMuted = ref false;
+
+        (* 121 *)
+    fun isNewline #"\n" = true
+      | isNewline _ = false;
+
+    (* 122 *)
+    fun push stack item = stack := item :: ! stack; 
+
+    (* 221 *)
+    fun installPrintingLimitSettings settings =
+          ListPair.app (op :=) (printingLimitRefs, settings);
+
+    (* 11 *)
+    fun saveControlPrintOut () = 
+            if isSome (! savedControlPrintOut)
+            then ()
+            else savedControlPrintOut := SOME (! Control.Print.out);
+
+    (* 12 *)
+    fun stashCompilerOutput string
+      = case String.fields isNewline string   
+         of nil => raise (Fail "impossible ") (* 121 *)
+          | [chunk] => push compilerOutputCurrentLine chunk (* 122 *)
+          | chunk :: lines
+            => (if chunk <> "" then push compilerOutputCurrentLine chunk else ();
+                push compilerOutputPreviousFullLines
+                     (String.concat (rev (! compilerOutputCurrentLine)));
+                let val (last :: others) = rev lines
+                in app (push compilerOutputPreviousFullLines)
+                       (rev others);
+                   compilerOutputCurrentLine
+                   := (if last <> "" then [last] else [])
+                end);
+
+    (* 13 *)
+    fun savePrintingLimits () =
+            if isSome (! savedPrintingLimitSettings)
+            then ()
+            else savedPrintingLimitSettings := SOME (map ! printingLimitRefs);
+
+    (* 14 *)
+    fun lowerPrintingLimitsToMin () =
+          List.app (fn r => r := 0) printingLimitRefs;
+
+    (* 21 *)
+    fun restoreControlPrintOut () =
+            case ! savedControlPrintOut of
+                NONE => ()
+              | SOME value => (savedControlPrintOut := NONE;
+                               Control.Print.out := value);
+    (* 22 *)
+    fun restorePrintingLimits () =
+            case ! savedPrintingLimitSettings of
+                NONE => ()
+              | SOME settings => (savedPrintingLimitSettings := NONE;
+                                  installPrintingLimitSettings settings); (* 221*)
+    (* 311 *)
+    fun outputFlush f s = (TextIO.output (f, s); TextIO.flushOut f);
+
+    (* 31 *)
+    val printStdErr = outputFlush TextIO.stdErr;
+
+    (* 1 *)
+    fun silenceCompiler () =
+           (compilerMuted := true;
+            saveControlPrintOut ();  (* 11 *)
+            Control.Print.out := { flush = fn () => (), say = stashCompilerOutput }; (* 12 *)
+            savePrintingLimits (); (* 13 *)
+            lowerPrintingLimitsToMin ()); (* 14 *)
+
+    (* 2 *)    
+    fun unsilenceCompiler () = (compilerMuted := false;
+                              restoreControlPrintOut (); (* 21 *)
+                              restorePrintingLimits ()); (* 22 *)
+
+    (* dummy function to silence the autoloading messages *)
+    fun mcdummyfn () = ( );
+
+    (* 3 *)
+    fun printStashedCompilerOutput ()
+      = let val completeLines = length (! compilerOutputPreviousFullLines)
+            val partialLine = 0 < length (! compilerOutputCurrentLine)
+            val partialLines = if partialLine then 1 else 0
+            val stashedOutput = 0 < completeLines orelse partialLine
+        in if stashedOutput andalso (!compilerMuted)
+          then (printStdErr ("___________________________________________________________________\n");
+                 let val linesShown
+                       = ((if partialLine then [String.concat (rev (! compilerOutputCurrentLine))] else [])
+                          @ List.take (! compilerOutputPreviousFullLines,
+                                       Int.min (completeLines,
+                                                !printlineLimit - partialLines)))
+                     val numLinesShown = length linesShown
+                     val last = completeLines + partialLines
+                     val first = last - numLinesShown + 1
+                 in printStdErr (String.concat ["The last " ^ Int.toString (!printlineLimit) ^ " lines " ^ Int.toString first ^ " through " ^ Int.toString last ^ " of suppressed compiler messages are:\n"]);
+                    foldr (fn (line, ()) => printStdErr (line ^ "\n"))
+                          ()
+                          linesShown
+                 end;
+                 printStdErr ("_____________End of suppressed compiler messages.__________________\n")
+                 )
+            else ()
+        end;
+  end
+
+  end (* structure Mutecompiler *)

base/compiler/core.cm

@@ -164,6 +164,10 @@ TopLevel/interact/evalloop.sml
 TopLevel/interact/interact.sig
 TopLevel/interact/interact.sml
 
+(* mutecompiler added as part of 'Excute as a script' change done by Dayanandan Natarajan Heriot Watt University *)
+TopLevel/interact/mutecompiler.sig
+TopLevel/interact/mutecompiler.sml
+
 TopLevel/backend/backend.sig
 TopLevel/backend/backend-fn.sml
 

base/system/smlnj/internal/boot-env-fn.sml

@@ -5,6 +5,9 @@
  *   completely redone by M.Blume (5/1998)
  *   ... and again in the course of switching over to the new CM
  *       (M. Blume, 7/1999)
+ *
+ * This module amended to include 'Execute as a script' change done by Dayanandan Natarajan, Heriot Watt University
+ *
  *)
 signature BOOTENV = sig
     val init:
@@ -15,6 +18,7 @@ functor BootEnvF (datatype envrequest = AUTOLOAD | BARE
 		  val architecture: string
 		  val cminit : string * DynamicEnv.env * envrequest
 			       * (TextIO.instream -> unit)(* useStream *)
+			       * (string * TextIO.instream -> unit) (* useScriptFile - added as part of 'Execute as a script' change *)
 			       * (string -> unit) (* useFile *)
 			       * ((string -> unit) -> (string -> unit))
 			                          (* errorwrap *)
@@ -70,6 +74,7 @@ functor BootEnvF (datatype envrequest = AUTOLOAD | BARE
 	      U.pStruct := U.NILrde;
 	      cminit (bootdir, de, er,
 		      Backend.Interact.useStream,
+		      Backend.Interact.useScriptFile, (* added as part of Execute as a script change *)
 		      errorwrap false useFile,
 		      errorwrap true,
 		      Backend.Interact.installCompManagers)