diff --git a/base/cm/main/cm-boot.sml b/base/cm/main/cm-boot.sml index 46202add..9327ea09 100644 --- a/base/cm/main/cm-boot.sml +++ b/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 \ .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\ \ .sig (use)\n\ \ .sml (use)\n\ \ .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 ()) diff --git a/base/compiler/INDEX b/base/compiler/INDEX index 2b3cf30c..c1a96773 100644 --- a/base/compiler/INDEX +++ b/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 diff --git a/base/compiler/MAP b/base/compiler/MAP index 052f9de5..7ba0980f 100644 --- a/base/compiler/MAP +++ b/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. \ No newline at end of file +general purpose libraries. diff --git a/base/compiler/TopLevel/backend/backend-fn.sml b/base/compiler/TopLevel/backend/backend-fn.sml index ac6a2986..622d3344 100644 --- a/base/compiler/TopLevel/backend/backend-fn.sml +++ b/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 diff --git a/base/compiler/TopLevel/backend/backend.sig b/base/compiler/TopLevel/backend/backend.sig index b48d8eac..3db24781 100644 --- a/base/compiler/TopLevel/backend/backend.sig +++ b/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 diff --git a/base/compiler/TopLevel/interact/interact.sig b/base/compiler/TopLevel/interact/interact.sig index be83754c..3fc6d33a 100644 --- a/base/compiler/TopLevel/interact/interact.sig +++ b/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 *) diff --git a/base/compiler/TopLevel/interact/interact.sml b/base/compiler/TopLevel/interact/interact.sml index e726ebcf..fdcc502d 100644 --- a/base/compiler/TopLevel/interact/interact.sml +++ b/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 ("", stream) + (* Function added as part of Execute as a script change*) + fun useScriptFile (fname, stream) = ( + Mutecompiler.silenceCompiler () ; + EvalLoop.evalStream ("", (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", diff --git a/base/compiler/TopLevel/interact/mutecompiler.sig b/base/compiler/TopLevel/interact/mutecompiler.sig new file mode 100644 index 00000000..6529a72d --- /dev/null +++ b/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 *) diff --git a/base/compiler/TopLevel/interact/mutecompiler.sml b/base/compiler/TopLevel/interact/mutecompiler.sml new file mode 100644 index 00000000..008d2b34 --- /dev/null +++ b/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 *) \ No newline at end of file diff --git a/base/compiler/core.cm b/base/compiler/core.cm index fb37edc0..5ae2ae74 100644 --- a/base/compiler/core.cm +++ b/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 diff --git a/base/system/smlnj/internal/boot-env-fn.sml b/base/system/smlnj/internal/boot-env-fn.sml index d9b2d1f6..12d81b0d 100644 --- a/base/system/smlnj/internal/boot-env-fn.sml +++ b/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)