From b383941a00790c8f60aa6d94c3a5936d7c2166a1 Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sat, 15 Apr 2023 18:20:28 +0100 Subject: [PATCH 1/9] Add files via upload MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Changes made in cm-boot.sml to recognise the new command line parameter passed from script. a) In function args, line added to recognise the new command-line parameter ‘--script’, and a new function ‘nextargscript’ is called to initiate the process of the file. b) In function init(), the new function (useScriptFile) is added as one of the parameter passed. c) In function procCmdLine (), new function processFileScript is added to process the script file, function will check for whether the file passed on is a script file starting with ‘#!’ thru another new function checkSharpbang, consumes the first line thru another new function eatuntilneline and pass the remaining content of the file to function useScriptFile. --- cm-boot.sml | 1021 +++++++++++++++++++++++++++++++++++++++++++++++++++ 1 file changed, 1021 insertions(+) create mode 100644 cm-boot.sml diff --git a/cm-boot.sml b/cm-boot.sml new file mode 100644 index 00000000..e9c19718 --- /dev/null +++ b/cm-boot.sml @@ -0,0 +1,1021 @@ +(* cm-boot.sml + * + * COPYRIGHT (c) 2022 The Fellowship of SML/NJ (http://www.smlnj.org) + * All rights reserved. + * + * This is the module that actually puts together the contents of the + * structure CM people find in $smlnj/cm/full.cm. + * + * author: Matthias Blume (blume@cs.princeton.edu) + *) + +functor LinkCM (structure HostBackend : BACKEND) = struct + + datatype envrequest = AUTOLOAD | BARE + + local + structure E = Environment + structure DE = DynamicEnv + structure SE = StaticEnv + structure ER = EnvRef + structure S = Symbol + structure EM = ErrorMsg + structure P = OS.Path + structure F = OS.FileSys + structure DG = DependencyGraph + structure GG = GroupGraph + structure IM = IntMap + + val os = SMLofNJ.SysInfo.getOSKind () + val my_archos = + concat [HostBackend.architecture, "-", FilenamePolicy.kind2name os] + + structure SSV = + SpecificSymValFn (val arch = HostBackend.architecture + val os = os + val abi_variant = HostBackend.abi_variant) + + val system_values = + ref (SrcPathMap.empty: E.dynenv IntMap.map SrcPathMap.map) + + structure StabModmap = StabModmapFn () + + val useStreamHook = + ref (fn _ => raise Fail "useStreamHook not initialized") + : (TextIO.instream -> unit) ref + + structure Compile = + CompileFn (structure Backend = HostBackend + structure StabModmap = StabModmap + fun useStream s = !useStreamHook s + val compile_there = Servers.compile o SrcPath.encode) + + structure BFC = + BfcFn (val arch = HostBackend.architecture) + + structure Link = + LinkFn (structure BFC = BFC + val system_values = system_values) + + structure AutoLoad = AutoLoadFn + (structure C = Compile + structure L = Link + structure BFC = BFC) + + val mkBootList = #l o MkBootList.group (fn p => p) + + fun init_servers (GG.GROUP { grouppath, ... }) = + Servers.cm { archos = my_archos, project = SrcPath.encode grouppath } + | init_servers GG.ERRORGROUP = () + + fun recomp_runner gp g = let + val _ = init_servers g + fun store _ = () + val { group, ... } = Compile.newTraversal (Link.evict, store, g) + in + isSome (Servers.withServers (fn () => group gp)) + before Link.cleanup gp + end + + (* This function combines the actions of "recompile" and "exec". + * When successful, it combines the results (thus forming a full + * environment) and adds it to the toplevel environment. *) + fun make_runner _ _ GG.ERRORGROUP = false + | make_runner add_bindings gp (g as GG.GROUP grec) = let + val { required = rq, ... } = grec + val { store, get } = BFC.new () + val _ = init_servers g + val { group = c_group, ... } = + Compile.newTraversal (Link.evict, store, g) + val { group = l_group, ... } = + Link.newTraversal (g, #contents o get) + in + case Servers.withServers (fn () => c_group gp) of + NONE => false + | SOME { stat, sym} => + (* Before executing the code, we announce the privileges + * that are being invoked. (For the time being, we assume + * that everybody has every conceivable privilege, but at + * the very least we announce which ones are being made + * use of.) *) + (Link.cleanup gp; + if StringSet.isEmpty rq then () + else Say.say ("$Execute: required privileges are:\n" :: + map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq)); + case l_group gp of + NONE => false + | SOME dyn => + (if add_bindings then + let val delta = E.mkenv { static = stat, + symbolic = sym, + dynamic = dyn } + val loc = ER.loc () + val base = #get loc () + val new = E.concatEnv (delta, base) + in + #set loc new; + Say.vsay ["[New bindings added.]\n"] + end + else (); + true)) + end + + val al_greg = GroupReg.new () + + (* Instantiate the stabilization mechanism. *) + structure Stabilize = + StabilizeFn (val arch = HostBackend.architecture + structure StabModmap = StabModmap + fun recomp gp g = let + val { store, get } = BFC.new () + val { group, ... } = + Compile.newTraversal (Link.evict, store, g) + in + case group gp of + NONE => NONE + | SOME _ => SOME get + end + val getII = Compile.getII) + + (* Access to the stabilization mechanism is integrated into the + * parser. I'm not sure if this is the cleanest way, but it works + * well enough. *) + structure Parse = ParseFn (structure Stabilize = Stabilize + structure StabModmap = StabModmap + fun evictStale () = + (Compile.evictStale (); + Link.evictStale ()) + val pending = AutoLoad.getPending) + + local + type kernelValues = { init_group : GG.group } + + val fnpolicy = FilenamePolicy.colocate + { os = os, arch = HostBackend.architecture } + + val theValues = ref (NONE: kernelValues option) + + in + val penv = SrcPath.newEnv () + + (* cancelling anchors cannot affect the order of existing paths + * (it may invalidate some paths; but all other ones stay as + * they are) *) + fun setAnchor a v = SrcPath.set_anchor (penv, a, v) + (* same goes for reset because it just cancels all anchors... *) + fun resetPathConfig () = SrcPath.reset_anchors penv + (* get the current binding for an anchor *) + fun getAnchor a () = SrcPath.get_anchor (penv, a) + (* make a source path from a string using the host OS pathname + * conventions. + *) + fun mkNativeSrcPath s = + SrcPath.file + (SrcPath.native + { err = fn s => raise Fail s, env = penv } + { context = SrcPath.cwd (), spec = s }) + (* make a source path from a string using CM standard path syntax *) + fun mkStdSrcPath s = + SrcPath.file + (SrcPath.standard + { err = fn s => raise Fail s, env = penv } + { context = SrcPath.cwd (), spec = s }) + + fun getPending () = + map (Symbol.describe o #1) + (SymbolMap.listItemsi (AutoLoad.getPending ())) + + fun showBindings () = let + val loaded = map Symbol.describe (EnvRef.listBoundSymbols ()) + val pending = getPending () + fun pr s = Say.say [s, "\n"] + in + Say.say ["\n*** Symbols bound at toplevel:\n"]; + app pr loaded; + Say.say ["\n*** Symbols registered for autoloading:\n"]; + app pr pending + end + + fun initPaths () = let + val lpcth = #get StdConfig.local_pathconfig () + val p = (case lpcth () of NONE => [] | SOME f => [f]) + val p = #get StdConfig.pathcfgspec () () :: p + fun processOne f = let + val work = SrcPath.processSpecFile + { env = penv, specfile = f, say = Say.say } + in + SafeIO.perform { openIt = fn () => TextIO.openIn f, + closeIt = TextIO.closeIn, + work = work, + cleanup = fn _ => () } + end handle _ => () + in + app processOne p; + SrcPath.sync () + end + + fun getTheValues () = valOf (!theValues) + handle Option => raise Fail "CMBoot: theValues not initialized" + + fun param slave_mode = + { fnpolicy = fnpolicy, + penv = penv, + symval = SSV.symval, + archos = my_archos, + keep_going = #get StdConfig.keep_going (), + slave_mode = slave_mode } + + val init_group = #init_group o getTheValues + + fun dropPickles () = + if #get StdConfig.conserve_memory () then + Parse.dropPickles () + else () + + fun parse_arg0 slave_mode (gr, sflag, p) = + { load_plugin = load_plugin, gr = gr, param = param slave_mode, + stabflag = sflag, group = p, + init_group = init_group (), paranoid = false } + + and parse_arg x = parse_arg0 false x + + and slave_parse_arg x = parse_arg0 true x + + and autoload mkSrcPath s = let + val p = mkSrcPath s + in + (case Parse.parse (parse_arg (al_greg, NONE, p)) + of NONE => false + | SOME (g, _) => ( + AutoLoad.register (EnvRef.loc (), g); + true) + (* end case *)) + before dropPickles () + end + + and run mkSrcPath sflag f s = let + val p = mkSrcPath s + val gr = GroupReg.new () + in + (case Parse.parse (parse_arg (gr, sflag, p)) of + NONE => false + | SOME (g, gp) => f gp g) + before dropPickles () + end + + and load_plugin' p = let + val d = SrcPath.descr p + val _ = Say.vsay ["[attempting to load plugin ", d, "]\n"] + val gr = GroupReg.new () + val success = + ((case Parse.parse (parse_arg (gr, NONE, p)) of + NONE => false + | SOME (g, gp) => make_runner false gp g) + before dropPickles ()) + handle _ => false + in + if success then + Say.vsay ["[plugin ", d, " loaded successfully]\n"] + else + Say.vsay ["[unable to load plugin ", d, "]\n"]; + success + end + + and load_plugin context s = let + fun badname s = Say.say ["[bad plugin name: ", s, "]\n"] + val pp = SrcPath.standard { env = penv, err = badname } + { context = context, spec = s } + in + load_plugin' (SrcPath.file pp) + end + + fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x + + fun stabilize mkSrcPath recursively root = let + fun stabilize_recomp_runner gp g = let + val _ = init_servers g + val { allgroups, ... } = + Compile.newTraversal (Link.evict, fn _ => (), g) + in + Servers.withServers (fn () => allgroups gp) + end + fun stabilize_dummy_runner gp g = true + fun phase1 () = run mkSrcPath NONE + stabilize_recomp_runner root + fun phase2 () = (Compile.reset ();(* a bit too draconian? *) + run mkSrcPath (SOME recursively) + stabilize_dummy_runner root) + in + (* Don't bother with the 2-phase thing if there are + * no compile servers attached. (We still need + * the "withServers" call to clean up our queues in case + * of an interrupt or error.) *) + if Servers.noServers () + then Servers.withServers phase2 + else + (* We do this in two phases: + * 1. recompile everything without stabilization but + * potentially using compile servers + * 2. do a local stabilization run (which should have + * no need to compile anything); don't use servers + *) + phase1 () andalso phase2 () + end + + fun recomp mkSrcPath = run mkSrcPath NONE recomp_runner + val makeNative = run mkNativeSrcPath NONE (make_runner true) + val makeStd = run mkStdSrcPath NONE (make_runner true) + + fun to_portable s = let + val gp = mkNativeSrcPath s + fun nativesrc s = let + val p = SrcPath.standard + { err = fn s => raise Fail s, env = penv } + { context = SrcPath.dir gp, spec = s } + in + SrcPath.osstring' (SrcPath.file p) + end + fun mkres (g, pl) = { graph = g, imports = pl, + nativesrc = nativesrc } + in + Option.map + (mkres o ToPortable.export) + (Parse.parse (parse_arg (GroupReg.new (), NONE, mkNativeSrcPath s))) + end + + fun sources archos group = + let val policy = + case archos of + NONE => fnpolicy + | SOME ao => FilenamePolicy.colocate_generic ao + fun snam (p, version) = FilenamePolicy.mkStableName + policy (p, version) + fun insert0 (a, f, x) = StringMap.insert (a, f, x) + fun insert (a, p, x) = insert0 (a, SrcPath.osstring p, x) + fun add (s, p) = SrcPathSet.add (s, p) + + fun addSources (subgroups, sources, a, v) = + let fun findSG p = + List.find (fn (p', _, _) => + SrcPath.compare (p, p') = EQUAL) + subgroups + fun one (p, x as { class, derived }, (a, v)) = + if SrcPathSet.member (v, p) then (a, v) + else if class = "cm" then + case findSG p of + NONE => (a, v) (* unused group/library *) + | SOME (_, gth, _) => + addGroup (p, x, gth, a, add (v, p)) + else (insert (a, p, x), add (v, p)) + in SrcPathMap.foldli one (a, v) sources + end + + and addGroup (p, x, gth, a, v) = + case gth () of + GG.ERRORGROUP => (a, v) + | GG.GROUP { kind, sources, ... } => + (case kind of + GG.LIB { kind, version } => + (case kind of + GG.STABLE _ => + (insert0 (a, snam (p, version), x), v) + | GG.DEVELOPED d => + addSources (#subgroups d, sources, + insert (a, p, x), v)) + | GG.NOLIB n => + addSources (#subgroups n, sources, + insert (a, p, x), v)) + + val p = mkNativeSrcPath group + val gr = GroupReg.new () + val x0 = { class = "cm", derived = false } + fun doit () = + case Parse.parse (parse_arg (gr, NONE, p)) of + SOME (g, _) => + let val (sm, _) = + addGroup (p, x0, fn () => g, + StringMap.empty, + SrcPathSet.singleton p) + fun add (f, { class, derived }, l) = + { file = f, class = class, + derived = derived } :: l + in SOME (StringMap.foldli add [] sm) + end + | NONE => NONE + in doit () before dropPickles () + end + + fun mk_standalone sflag { setup, project, wrapper, target } = let + val hsfx = SMLofNJ.SysInfo.getHeapSuffix () + fun extendTarget () = + OS.Path.joinBaseExt { base = target, ext = SOME hsfx } + val target = + case OS.Path.splitBaseExt target of + { base, ext = NONE } => extendTarget () + | { base, ext = SOME e } => + if e = hsfx then target else extendTarget () + val spopt = Option.map mkNativeSrcPath setup + val pp = mkNativeSrcPath project + val wp = mkNativeSrcPath wrapper + val ts = TStamp.fmodTime target + val gr = GroupReg.new () + fun do_cmfile p = + case Parse.parse (parse_arg (gr, NONE, p)) of + NONE => NONE + | SOME (g, gp) => + if recomp_runner gp g then SOME (mkBootList g) + else NONE + val setup_list = + case spopt of + SOME sp => getOpt (do_cmfile sp, []) + | NONE => [] + fun in_setup (i, _) = + List.exists (MkBootList.same_info i o #1) setup_list + fun do_wrapper () = + case do_cmfile wp of + NONE => NONE + | SOME l => + SOME (map #2 (setup_list @ + List.filter (not o in_setup) l)) + in + (case Parse.parse (parse_arg (gr, sflag, pp)) of + NONE => NONE + | SOME (g, gp) => + if isSome sflag orelse recomp_runner gp g then + case (ts, !(#youngest gp)) of + (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) => + if Time.< (tgt_t, src_t) then do_wrapper () + else SOME [] + | _ => do_wrapper () + else NONE) + before dropPickles () + end + + fun redump_heap s : unit = + SMLofNJ.Cont.throw (!HostBackend.Interact.redump_heap_cont) s + + fun slave () = let + val gr = GroupReg.new () + fun parse p = Parse.parse (slave_parse_arg (gr, NONE, p)) + in + #set (SSV.symval "CM_SLAVE_MODE") (SOME 1); + #set (SSV.symval "NO_PLUGINS") (SOME 1); + Slave.slave { penv = penv, + parse = parse, + my_archos = my_archos, + sbtrav = Compile.newSbnodeTraversal, + make = makeNative } + end + + (* This function works on behalf of the ml-build script. + * Having it here avoids certain startup-costs and also + * keeps ML code together. (It used to be part of the + * script, but that proved difficult to maintain.) *) + fun mlbuild buildargs = + let fun doit (setup, root, cmfile, heap, listfile, linkargsfile) = + case mk_standalone NONE { setup = setup, + project = root, + wrapper = cmfile, + target = heap } of + NONE => (Say.say ["Compilation failed.\n"]; + OS.Process.failure) + | SOME [] => + (Say.say ["Heap was already up-to-date.\n"]; + OS.Process.success) + | SOME l => let + fun wrf (f, l) = + let val s = TextIO.openOut f + fun wr str = + TextIO.output (s, str ^ "\n") + in + app wr l; + TextIO.closeOut s + end + + val s = TextIO.openOut listfile + fun wr str = TextIO.output (s, str ^ "\n") + val n = length l + fun maxsz (s, n) = Int.max (size s, n) + val m = foldl maxsz 0 l + in + wrf (listfile, + concat ["%", Int.toString n, " ", + Int.toString m] + :: l); + wrf (linkargsfile, + [concat [" @SMLboot=", listfile]]); + OS.Process.success + end handle _ => OS.Process.failure + in + OS.Process.exit + (case buildargs of + [root, cmfile, heap, listfile, linkargsfile] => + doit (NONE, root, cmfile, heap, listfile, + linkargsfile) + | [setup, + root, cmfile, heap, listfile, linkargsfile] => + doit (SOME setup, root, cmfile, heap, listfile, + linkargsfile) + | _ => (Say.say ["bad arguments to @CMbuild\n"]; + OS.Process.failure)) + end + + fun al_ginfo () = { param = param false, + groupreg = al_greg, + errcons = EM.defaultConsumer (), + youngest = ref TStamp.ancient } + + val al_managers = + AutoLoad.mkManagers { get_ginfo = al_ginfo, + dropPickles = dropPickles } + + fun reset () = + (Compile.reset (); + Link.reset (); + AutoLoad.reset (); + Parse.reset (); + SmlInfo.reset (); + StabModmap.reset ()) + + fun initTheValues (bootdir, de, er, autoload_postprocess, icm) = let + (* icm: "install compilation manager" *) + val _ = let + fun listDir ds = let + fun loop l = + case F.readDir ds of + NONE => l + | SOME x => loop (x :: l) + in + loop [] + end + val fileList = SafeIO.perform + { openIt = fn () => F.openDir bootdir, + closeIt = F.closeDir, + work = listDir, + cleanup = fn _ => () } + fun isDir x = F.isDir x handle _ => false + fun subDir x = let + val d = P.concat (bootdir, x) + in + if isDir d then SOME (x, d) else NONE + end + val pairList = List.mapPartial subDir fileList + fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d) + in + app sa pairList + end + + val pidmapfile = P.concat (bootdir, BtNames.pidmap) + + fun readpidmap s = let + fun loop m = let + fun enter (d, pids) = let + fun enter1 (spec, pm) = let + val fromHex = PersStamps.fromHex + in + case String.tokens (fn c => c = #":") spec of + [pos, hexp] => + (case (fromHex hexp, Int.fromString pos) of + (SOME p, SOME i) => + (case DE.look de p of + NONE => pm + | SOME obj => + IM.insert (pm, i, + DE.singleton (p, obj))) + | _ => pm) + | _ => pm + end + in + SrcPathMap.insert (m, SrcPath.decode penv d, + foldl enter1 IM.empty pids) + end + in + case TextIO.inputLine s of + NONE => m + | SOME line => + (case String.tokens Char.isSpace line of + d :: pids => loop (enter (d, pids)) + | _ => loop m) + end + val m = loop SrcPathMap.empty + in + system_values := m + end + + val _ = + SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile, + closeIt = TextIO.closeIn, + work = readpidmap, + cleanup = fn _ => () } + + val initgspec = mkStdSrcPath BtNames.initgspec + val ginfo = { param = { fnpolicy = fnpolicy, + penv = penv, + symval = SSV.symval, + archos = my_archos, + keep_going = false, + slave_mode = false }, + groupreg = GroupReg.new (), + errcons = EM.defaultConsumer (), + youngest = ref TStamp.ancient } + fun loadInitGroup () = + Stabilize.loadStable + { getGroup = fn _ => + raise Fail "CMBoot: initial getGroup", + anyerrors = ref false } + (ginfo, initgspec, NONE, []) + in + case loadInitGroup () of + NONE => raise Fail "CMBoot: unable to load init group" + | SOME init_group => let + val _ = Compile.reset () + val _ = Link.reset () + + val { exports = ctm, ... } = + Compile.newTraversal (fn _ => fn _ => (), + fn _ => (), + init_group) + val { exports = ltm, ... } = Link.newTraversal + (init_group, fn _ => raise Fail "init: get bfc?") + + fun getSymTrav (tr_m, sy) = + case SymbolMap.find (tr_m, sy) of + NONE => raise Fail "init: bogus init group (1)" + | SOME tr => tr + + val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym) + val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym) + + fun doTrav t = + case t ginfo of + SOME r => r + | NONE => raise Fail "init: bogus init group (2)" + + val { stat = pervstat, sym = pervsym } = doTrav perv_ct + val pervdyn = doTrav perv_lt + + val pervasive = E.mkenv { static = pervstat, + symbolic = pervsym, + dynamic = pervdyn } + + fun bare_autoload x = + (Say.say + ["!* ", x, + ": \"autoload\" not available, using \"make\"\n"]; + makeStd x) + val bare_preload = Preload.preload { + make = makeStd, + autoload = bare_autoload + } + val standard_preload = Preload.preload { + make = makeStd, + autoload = autoload mkStdSrcPath + } + in + #set ER.pervasive pervasive; + #set (ER.loc ()) E.emptyEnv;(* redundant? *) + theValues := SOME { init_group = init_group }; + case er of + BARE => + (bare_preload BtNames.bare_preloads; + system_values := SrcPathMap.empty; + NONE) + | AUTOLOAD => + (icm al_managers; + standard_preload BtNames.standard_preloads; + (* unconditionally drop all library pickles *) + Parse.dropPickles (); + SOME (autoload_postprocess ())) + end + end + end + in + 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) + fun processFile (file, mk, ext) = (case ext + of ("sml" | "sig" | "fun") => useFile file + | "cm" => mk file + | _ => Say.say [ + "!* unable to process '", file, "' (unknown extension '", ext, "')\n" + ] + (* end case *)) + + (* DAYA change starts here *) + 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 + (* DAYA change ends here *) + + fun inc n = n + 1 + fun show_controls (getarg, getval, padval) level = let + fun walk indent (ControlRegistry.RTree rt) = let + open FormatComb + val { help, ctls, subregs, path } = rt + + fun one ci = let + val arg = concat (foldr (fn (s, r) => s :: "." :: r) + [getarg ci] path) + val value = getval ci + val sz = size value + val lw = !Control_Print.linewidth + val padsz = lw - 6 - size arg - indent + in + if padsz < sz then + let val padsz' = Int.max (lw, sz + 8 + indent) + in + format' Say.say (sp (indent + 6) o + text arg o nl o + padval padsz' (text value) o + nl) + end + else format' Say.say (sp (indent + 6) o + text arg o + padval padsz (text value) o + nl) + end + in + case (ctls, subregs) of + ([], []) => () + | _ => (format' Say.say + (sp indent o text help o text ":" o nl); + app one ctls; + app (walk (indent + 1)) subregs) + end + in + walk 2 (ControlRegistry.controls + (BasicControl.topregistry, Option.map inc level)) + end + + (* !!Important!! + * This message should be kept in sync with the manpage (doc/src/man/sml.1.txt) + *) + fun help level = (Say.say [ + "\ + \sml [rtsargs] [options] [files]\n\ + \\n\ + \ rtsargs:\n\ + \ @SMLversion (echo the version of SML/NJ then exit)\n\ + \ @SMLwordsize (echo the wordsze for the system then exit)\n\ + \ @SMLsuffix (echo the heap suffix for the system then exit)\n\ + \ @SMLload= (load specified heap image)\n\ + \ @SMLcmdname= (set command name)\n\ + \ @SMLalloc= (specify size of allocation area)\n\ + \ @SMLrun= (specify runtime system)\n\ + \ @SMLquiet (load heap image silently)\n\ + \ @SMLverbose (show heap image load progress)\n\ + \ @SMLobjects (show list of executable objects)\n\ + \ @SMLdebug= (write debugging info to file)\n\ + \\n\ + \ options:\n\ + \ -D= (set CM variable to given value)\n\ + \ -D (set CM variable to 1)\n\ + \ -Uname (unset CM variable)\n\ + \ -C= (set named control)\n\ + \ -H (produce complete help listing)\n\ + \ -h (produce minimal help listing)\n\ + \ -h (help with obscurity limit)\n\ + \ -S (list all current settings)\n\ + \ -s (limited list of settings)\n\ + \ -E (list all environment variables)\n\ + \ -e (list limited list of environment variables)\n\n\ + \\n\ + \ files:\n\ + \ .cm (CM.make or CM.autoload)\n\ + \ -m (switch to CM.make)\n\ + \ -a (switch to CM.autoload; default)\n\ + \ --script (execute scripts)\n\ + \ .sig (use)\n\ + \ .sml (use)\n\ + \ .fun (use)\n\ + \" + ]; + show_controls (Controls.name o #ctl, + fn ci => + concat ["(", #help (Controls.info (#ctl ci)), + ")"], + FormatComb.pad FormatComb.left) + level) + + fun showcur level = + show_controls (fn ci => (Controls.name (#ctl ci) ^ "="), + fn ci => Controls.get (#ctl ci), + fn _ => fn ff => ff) + level + + fun show_envvars level = + show_controls (fn ci => (Controls.name (#ctl ci) ^ ":"), + fn ci => Option.getOpt (#envName (#info ci), + "(none)"), + FormatComb.pad FormatComb.left) + level + + fun badopt opt f () = + Say.say ["!* bad ", opt, " option: `", f, "'\n", + "!* try `-h' or `-h' for help\n"] + + fun quit () = OS.Process.exit OS.Process.success + + fun quit_if true = quit () + | quit_if false = () + + fun carg (opt as ("-C" | "-D"), f, _, _) = + let val bad = badopt opt f + val spec = Substring.extract (f, 2, NONE) + val is_config = opt = "-C" + val (name, value) = + Substring.splitl (fn c => c <> #"=") spec + val name = Substring.string name + val value = Substring.string + (if Substring.size value > 0 then + Substring.slice (value, 1, NONE) + else value) + in + if name = "" then bad () + else if is_config then + let val names = String.fields (fn c => c = #".") name + val look = ControlRegistry.control + BasicControl.topregistry + in + case look names of + NONE => Say.say ["!* no such control: ", + name, "\n"] + | SOME sctl => + (Controls.set (sctl, value) + handle Controls.ValueSyntax vse => + Say.say ["!* unable to parse value `", + #value vse, "' for ", + #ctlName vse, " : ", + #tyName vse, "\n"]) + end + else if value = "" then #set (SSV.symval name) (SOME 1) + else (case Int.fromString value of + SOME i => #set (SSV.symval name) (SOME i) + | NONE => bad ()) + end + | carg ("-U", f, _, _) = + (case String.extract (f, 2, NONE) of + "" => badopt "-U" f () + | var => #set (SSV.symval var) NONE) + | carg ("-h", f, _, last) = + (case String.extract (f, 2, NONE) of + "" => help (SOME 0) + | level => help (Int.fromString level); + quit_if last) + | carg ("-s", f, _, last) = + (case String.extract (f, 2, NONE) of + "" => showcur (SOME 0) + | level => showcur (Int.fromString level); + quit_if last) + | carg ("-e", f, _, last) = + (case String.extract (f, 2, NONE) of + "" => show_envvars (SOME 0) + | level => show_envvars (Int.fromString level); + quit_if last) + | carg (_, f, mk, _) = + processFile (f, mk, String.map Char.toLower + (getOpt (OS.Path.ext f, ""))) + + fun args ([], _) = () + | args ("-a" :: _, _) = nextarg autoload' + | args ("-m" :: _, _) = nextarg make' + | args (["-H"], _) = (help NONE; quit ()) + | args ("-H" :: _ :: _, mk) = (help NONE; nextarg mk) + | args (["-S"], _) = (showcur NONE; quit ()) + | args ("-S" :: _ :: _, mk) = (showcur NONE; nextarg mk) + | args (["-E"], _) = (show_envvars NONE; quit ()) + | args ("-E" :: _ :: _, mk) = (show_envvars NONE; nextarg mk) + | args ("--script" :: _, _) = (nextargscript ()) (* line added by Daya HWU *) + | args ("@CMbuild" :: rest, _) = mlbuild rest + | args (["@CMredump", heapfile], _) = redump_heap heapfile + | args (f :: rest, mk) = + (carg (String.substring (f, 0, 2) + handle General.Subscript => "", + f, mk, List.null rest); + nextarg mk) + + and nextarg mk = + let val l = SMLofNJ.getArgs () + in SMLofNJ.shiftArgs (); args (l, mk) + end + + (* nextargscript added by Daya HWU *) + 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 ()) + | l => (SMLofNJ.shiftArgs (); args (l, autoload')) + end + in + useStreamHook := useStream; + initTheValues (bootdir, de, er, + fn () => (Cleanup.install initPaths; + procCmdLine), + icm) + end + + structure CM = struct + type 'a controller = { get : unit -> 'a, set : 'a -> unit } + + structure Anchor = struct + fun anchor a = { get = getAnchor a, set = setAnchor a } + val reset = resetPathConfig + end + + structure Control = struct + val keep_going = StdConfig.keep_going + val verbose = StdConfig.verbose + val parse_caching = StdConfig.parse_caching + val warn_obsolete = StdConfig.warn_obsolete + val debug = StdConfig.debug + val conserve_memory = StdConfig.conserve_memory + val generate_index = StdConfig.generate_index + end + + structure Library = struct + type lib = SrcPath.file + val known = Parse.listLibs + val descr = SrcPath.descr + val osstring = SrcPath.osstring + val dismiss = Parse.dismissLib + fun unshare lib = (Link.unshare lib; dismiss lib) + end + + structure State = struct + val synchronize = SrcPath.sync + val reset = reset + val pending = getPending + val showBindings = showBindings + end + + structure Server = struct + type server = Servers.server_handle + fun start x = Servers.start x + before SrcPath.scheduleNotification () + val stop = Servers.stop + val kill = Servers.kill + val name = Servers.name + end + + (* note that we use the "standard" path syntax during the bootstrapping + * process, but switch to native paths for the use of CM in the REPL. + *) + val autoload = autoload mkNativeSrcPath + val make = makeNative + val recomp = recomp mkNativeSrcPath + val stabilize = stabilize mkNativeSrcPath + + val sources = sources + + val symval = SSV.symval + val load_plugin = cwd_load_plugin + val mk_standalone = mk_standalone + + structure Graph = struct + val graph = to_portable + end + + val cm_dir_arc = FilenamePolicy.cm_dir_arc + + val redump_heap = redump_heap + end + + structure Tools = ToolsFn (val load_plugin' = load_plugin' + val penv = penv) + + val load_plugin = load_plugin + end +end (* end functor *) From 1acd084c57d4f68d9b3d8292e335be2da007ffb4 Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sat, 15 Apr 2023 18:21:16 +0100 Subject: [PATCH 2/9] Delete cm-boot.sml --- cm-boot.sml | 1021 --------------------------------------------------- 1 file changed, 1021 deletions(-) delete mode 100644 cm-boot.sml diff --git a/cm-boot.sml b/cm-boot.sml deleted file mode 100644 index e9c19718..00000000 --- a/cm-boot.sml +++ /dev/null @@ -1,1021 +0,0 @@ -(* cm-boot.sml - * - * COPYRIGHT (c) 2022 The Fellowship of SML/NJ (http://www.smlnj.org) - * All rights reserved. - * - * This is the module that actually puts together the contents of the - * structure CM people find in $smlnj/cm/full.cm. - * - * author: Matthias Blume (blume@cs.princeton.edu) - *) - -functor LinkCM (structure HostBackend : BACKEND) = struct - - datatype envrequest = AUTOLOAD | BARE - - local - structure E = Environment - structure DE = DynamicEnv - structure SE = StaticEnv - structure ER = EnvRef - structure S = Symbol - structure EM = ErrorMsg - structure P = OS.Path - structure F = OS.FileSys - structure DG = DependencyGraph - structure GG = GroupGraph - structure IM = IntMap - - val os = SMLofNJ.SysInfo.getOSKind () - val my_archos = - concat [HostBackend.architecture, "-", FilenamePolicy.kind2name os] - - structure SSV = - SpecificSymValFn (val arch = HostBackend.architecture - val os = os - val abi_variant = HostBackend.abi_variant) - - val system_values = - ref (SrcPathMap.empty: E.dynenv IntMap.map SrcPathMap.map) - - structure StabModmap = StabModmapFn () - - val useStreamHook = - ref (fn _ => raise Fail "useStreamHook not initialized") - : (TextIO.instream -> unit) ref - - structure Compile = - CompileFn (structure Backend = HostBackend - structure StabModmap = StabModmap - fun useStream s = !useStreamHook s - val compile_there = Servers.compile o SrcPath.encode) - - structure BFC = - BfcFn (val arch = HostBackend.architecture) - - structure Link = - LinkFn (structure BFC = BFC - val system_values = system_values) - - structure AutoLoad = AutoLoadFn - (structure C = Compile - structure L = Link - structure BFC = BFC) - - val mkBootList = #l o MkBootList.group (fn p => p) - - fun init_servers (GG.GROUP { grouppath, ... }) = - Servers.cm { archos = my_archos, project = SrcPath.encode grouppath } - | init_servers GG.ERRORGROUP = () - - fun recomp_runner gp g = let - val _ = init_servers g - fun store _ = () - val { group, ... } = Compile.newTraversal (Link.evict, store, g) - in - isSome (Servers.withServers (fn () => group gp)) - before Link.cleanup gp - end - - (* This function combines the actions of "recompile" and "exec". - * When successful, it combines the results (thus forming a full - * environment) and adds it to the toplevel environment. *) - fun make_runner _ _ GG.ERRORGROUP = false - | make_runner add_bindings gp (g as GG.GROUP grec) = let - val { required = rq, ... } = grec - val { store, get } = BFC.new () - val _ = init_servers g - val { group = c_group, ... } = - Compile.newTraversal (Link.evict, store, g) - val { group = l_group, ... } = - Link.newTraversal (g, #contents o get) - in - case Servers.withServers (fn () => c_group gp) of - NONE => false - | SOME { stat, sym} => - (* Before executing the code, we announce the privileges - * that are being invoked. (For the time being, we assume - * that everybody has every conceivable privilege, but at - * the very least we announce which ones are being made - * use of.) *) - (Link.cleanup gp; - if StringSet.isEmpty rq then () - else Say.say ("$Execute: required privileges are:\n" :: - map (fn s => (" " ^ s ^ "\n")) (StringSet.listItems rq)); - case l_group gp of - NONE => false - | SOME dyn => - (if add_bindings then - let val delta = E.mkenv { static = stat, - symbolic = sym, - dynamic = dyn } - val loc = ER.loc () - val base = #get loc () - val new = E.concatEnv (delta, base) - in - #set loc new; - Say.vsay ["[New bindings added.]\n"] - end - else (); - true)) - end - - val al_greg = GroupReg.new () - - (* Instantiate the stabilization mechanism. *) - structure Stabilize = - StabilizeFn (val arch = HostBackend.architecture - structure StabModmap = StabModmap - fun recomp gp g = let - val { store, get } = BFC.new () - val { group, ... } = - Compile.newTraversal (Link.evict, store, g) - in - case group gp of - NONE => NONE - | SOME _ => SOME get - end - val getII = Compile.getII) - - (* Access to the stabilization mechanism is integrated into the - * parser. I'm not sure if this is the cleanest way, but it works - * well enough. *) - structure Parse = ParseFn (structure Stabilize = Stabilize - structure StabModmap = StabModmap - fun evictStale () = - (Compile.evictStale (); - Link.evictStale ()) - val pending = AutoLoad.getPending) - - local - type kernelValues = { init_group : GG.group } - - val fnpolicy = FilenamePolicy.colocate - { os = os, arch = HostBackend.architecture } - - val theValues = ref (NONE: kernelValues option) - - in - val penv = SrcPath.newEnv () - - (* cancelling anchors cannot affect the order of existing paths - * (it may invalidate some paths; but all other ones stay as - * they are) *) - fun setAnchor a v = SrcPath.set_anchor (penv, a, v) - (* same goes for reset because it just cancels all anchors... *) - fun resetPathConfig () = SrcPath.reset_anchors penv - (* get the current binding for an anchor *) - fun getAnchor a () = SrcPath.get_anchor (penv, a) - (* make a source path from a string using the host OS pathname - * conventions. - *) - fun mkNativeSrcPath s = - SrcPath.file - (SrcPath.native - { err = fn s => raise Fail s, env = penv } - { context = SrcPath.cwd (), spec = s }) - (* make a source path from a string using CM standard path syntax *) - fun mkStdSrcPath s = - SrcPath.file - (SrcPath.standard - { err = fn s => raise Fail s, env = penv } - { context = SrcPath.cwd (), spec = s }) - - fun getPending () = - map (Symbol.describe o #1) - (SymbolMap.listItemsi (AutoLoad.getPending ())) - - fun showBindings () = let - val loaded = map Symbol.describe (EnvRef.listBoundSymbols ()) - val pending = getPending () - fun pr s = Say.say [s, "\n"] - in - Say.say ["\n*** Symbols bound at toplevel:\n"]; - app pr loaded; - Say.say ["\n*** Symbols registered for autoloading:\n"]; - app pr pending - end - - fun initPaths () = let - val lpcth = #get StdConfig.local_pathconfig () - val p = (case lpcth () of NONE => [] | SOME f => [f]) - val p = #get StdConfig.pathcfgspec () () :: p - fun processOne f = let - val work = SrcPath.processSpecFile - { env = penv, specfile = f, say = Say.say } - in - SafeIO.perform { openIt = fn () => TextIO.openIn f, - closeIt = TextIO.closeIn, - work = work, - cleanup = fn _ => () } - end handle _ => () - in - app processOne p; - SrcPath.sync () - end - - fun getTheValues () = valOf (!theValues) - handle Option => raise Fail "CMBoot: theValues not initialized" - - fun param slave_mode = - { fnpolicy = fnpolicy, - penv = penv, - symval = SSV.symval, - archos = my_archos, - keep_going = #get StdConfig.keep_going (), - slave_mode = slave_mode } - - val init_group = #init_group o getTheValues - - fun dropPickles () = - if #get StdConfig.conserve_memory () then - Parse.dropPickles () - else () - - fun parse_arg0 slave_mode (gr, sflag, p) = - { load_plugin = load_plugin, gr = gr, param = param slave_mode, - stabflag = sflag, group = p, - init_group = init_group (), paranoid = false } - - and parse_arg x = parse_arg0 false x - - and slave_parse_arg x = parse_arg0 true x - - and autoload mkSrcPath s = let - val p = mkSrcPath s - in - (case Parse.parse (parse_arg (al_greg, NONE, p)) - of NONE => false - | SOME (g, _) => ( - AutoLoad.register (EnvRef.loc (), g); - true) - (* end case *)) - before dropPickles () - end - - and run mkSrcPath sflag f s = let - val p = mkSrcPath s - val gr = GroupReg.new () - in - (case Parse.parse (parse_arg (gr, sflag, p)) of - NONE => false - | SOME (g, gp) => f gp g) - before dropPickles () - end - - and load_plugin' p = let - val d = SrcPath.descr p - val _ = Say.vsay ["[attempting to load plugin ", d, "]\n"] - val gr = GroupReg.new () - val success = - ((case Parse.parse (parse_arg (gr, NONE, p)) of - NONE => false - | SOME (g, gp) => make_runner false gp g) - before dropPickles ()) - handle _ => false - in - if success then - Say.vsay ["[plugin ", d, " loaded successfully]\n"] - else - Say.vsay ["[unable to load plugin ", d, "]\n"]; - success - end - - and load_plugin context s = let - fun badname s = Say.say ["[bad plugin name: ", s, "]\n"] - val pp = SrcPath.standard { env = penv, err = badname } - { context = context, spec = s } - in - load_plugin' (SrcPath.file pp) - end - - fun cwd_load_plugin x = load_plugin (SrcPath.cwd ()) x - - fun stabilize mkSrcPath recursively root = let - fun stabilize_recomp_runner gp g = let - val _ = init_servers g - val { allgroups, ... } = - Compile.newTraversal (Link.evict, fn _ => (), g) - in - Servers.withServers (fn () => allgroups gp) - end - fun stabilize_dummy_runner gp g = true - fun phase1 () = run mkSrcPath NONE - stabilize_recomp_runner root - fun phase2 () = (Compile.reset ();(* a bit too draconian? *) - run mkSrcPath (SOME recursively) - stabilize_dummy_runner root) - in - (* Don't bother with the 2-phase thing if there are - * no compile servers attached. (We still need - * the "withServers" call to clean up our queues in case - * of an interrupt or error.) *) - if Servers.noServers () - then Servers.withServers phase2 - else - (* We do this in two phases: - * 1. recompile everything without stabilization but - * potentially using compile servers - * 2. do a local stabilization run (which should have - * no need to compile anything); don't use servers - *) - phase1 () andalso phase2 () - end - - fun recomp mkSrcPath = run mkSrcPath NONE recomp_runner - val makeNative = run mkNativeSrcPath NONE (make_runner true) - val makeStd = run mkStdSrcPath NONE (make_runner true) - - fun to_portable s = let - val gp = mkNativeSrcPath s - fun nativesrc s = let - val p = SrcPath.standard - { err = fn s => raise Fail s, env = penv } - { context = SrcPath.dir gp, spec = s } - in - SrcPath.osstring' (SrcPath.file p) - end - fun mkres (g, pl) = { graph = g, imports = pl, - nativesrc = nativesrc } - in - Option.map - (mkres o ToPortable.export) - (Parse.parse (parse_arg (GroupReg.new (), NONE, mkNativeSrcPath s))) - end - - fun sources archos group = - let val policy = - case archos of - NONE => fnpolicy - | SOME ao => FilenamePolicy.colocate_generic ao - fun snam (p, version) = FilenamePolicy.mkStableName - policy (p, version) - fun insert0 (a, f, x) = StringMap.insert (a, f, x) - fun insert (a, p, x) = insert0 (a, SrcPath.osstring p, x) - fun add (s, p) = SrcPathSet.add (s, p) - - fun addSources (subgroups, sources, a, v) = - let fun findSG p = - List.find (fn (p', _, _) => - SrcPath.compare (p, p') = EQUAL) - subgroups - fun one (p, x as { class, derived }, (a, v)) = - if SrcPathSet.member (v, p) then (a, v) - else if class = "cm" then - case findSG p of - NONE => (a, v) (* unused group/library *) - | SOME (_, gth, _) => - addGroup (p, x, gth, a, add (v, p)) - else (insert (a, p, x), add (v, p)) - in SrcPathMap.foldli one (a, v) sources - end - - and addGroup (p, x, gth, a, v) = - case gth () of - GG.ERRORGROUP => (a, v) - | GG.GROUP { kind, sources, ... } => - (case kind of - GG.LIB { kind, version } => - (case kind of - GG.STABLE _ => - (insert0 (a, snam (p, version), x), v) - | GG.DEVELOPED d => - addSources (#subgroups d, sources, - insert (a, p, x), v)) - | GG.NOLIB n => - addSources (#subgroups n, sources, - insert (a, p, x), v)) - - val p = mkNativeSrcPath group - val gr = GroupReg.new () - val x0 = { class = "cm", derived = false } - fun doit () = - case Parse.parse (parse_arg (gr, NONE, p)) of - SOME (g, _) => - let val (sm, _) = - addGroup (p, x0, fn () => g, - StringMap.empty, - SrcPathSet.singleton p) - fun add (f, { class, derived }, l) = - { file = f, class = class, - derived = derived } :: l - in SOME (StringMap.foldli add [] sm) - end - | NONE => NONE - in doit () before dropPickles () - end - - fun mk_standalone sflag { setup, project, wrapper, target } = let - val hsfx = SMLofNJ.SysInfo.getHeapSuffix () - fun extendTarget () = - OS.Path.joinBaseExt { base = target, ext = SOME hsfx } - val target = - case OS.Path.splitBaseExt target of - { base, ext = NONE } => extendTarget () - | { base, ext = SOME e } => - if e = hsfx then target else extendTarget () - val spopt = Option.map mkNativeSrcPath setup - val pp = mkNativeSrcPath project - val wp = mkNativeSrcPath wrapper - val ts = TStamp.fmodTime target - val gr = GroupReg.new () - fun do_cmfile p = - case Parse.parse (parse_arg (gr, NONE, p)) of - NONE => NONE - | SOME (g, gp) => - if recomp_runner gp g then SOME (mkBootList g) - else NONE - val setup_list = - case spopt of - SOME sp => getOpt (do_cmfile sp, []) - | NONE => [] - fun in_setup (i, _) = - List.exists (MkBootList.same_info i o #1) setup_list - fun do_wrapper () = - case do_cmfile wp of - NONE => NONE - | SOME l => - SOME (map #2 (setup_list @ - List.filter (not o in_setup) l)) - in - (case Parse.parse (parse_arg (gr, sflag, pp)) of - NONE => NONE - | SOME (g, gp) => - if isSome sflag orelse recomp_runner gp g then - case (ts, !(#youngest gp)) of - (TStamp.TSTAMP tgt_t, TStamp.TSTAMP src_t) => - if Time.< (tgt_t, src_t) then do_wrapper () - else SOME [] - | _ => do_wrapper () - else NONE) - before dropPickles () - end - - fun redump_heap s : unit = - SMLofNJ.Cont.throw (!HostBackend.Interact.redump_heap_cont) s - - fun slave () = let - val gr = GroupReg.new () - fun parse p = Parse.parse (slave_parse_arg (gr, NONE, p)) - in - #set (SSV.symval "CM_SLAVE_MODE") (SOME 1); - #set (SSV.symval "NO_PLUGINS") (SOME 1); - Slave.slave { penv = penv, - parse = parse, - my_archos = my_archos, - sbtrav = Compile.newSbnodeTraversal, - make = makeNative } - end - - (* This function works on behalf of the ml-build script. - * Having it here avoids certain startup-costs and also - * keeps ML code together. (It used to be part of the - * script, but that proved difficult to maintain.) *) - fun mlbuild buildargs = - let fun doit (setup, root, cmfile, heap, listfile, linkargsfile) = - case mk_standalone NONE { setup = setup, - project = root, - wrapper = cmfile, - target = heap } of - NONE => (Say.say ["Compilation failed.\n"]; - OS.Process.failure) - | SOME [] => - (Say.say ["Heap was already up-to-date.\n"]; - OS.Process.success) - | SOME l => let - fun wrf (f, l) = - let val s = TextIO.openOut f - fun wr str = - TextIO.output (s, str ^ "\n") - in - app wr l; - TextIO.closeOut s - end - - val s = TextIO.openOut listfile - fun wr str = TextIO.output (s, str ^ "\n") - val n = length l - fun maxsz (s, n) = Int.max (size s, n) - val m = foldl maxsz 0 l - in - wrf (listfile, - concat ["%", Int.toString n, " ", - Int.toString m] - :: l); - wrf (linkargsfile, - [concat [" @SMLboot=", listfile]]); - OS.Process.success - end handle _ => OS.Process.failure - in - OS.Process.exit - (case buildargs of - [root, cmfile, heap, listfile, linkargsfile] => - doit (NONE, root, cmfile, heap, listfile, - linkargsfile) - | [setup, - root, cmfile, heap, listfile, linkargsfile] => - doit (SOME setup, root, cmfile, heap, listfile, - linkargsfile) - | _ => (Say.say ["bad arguments to @CMbuild\n"]; - OS.Process.failure)) - end - - fun al_ginfo () = { param = param false, - groupreg = al_greg, - errcons = EM.defaultConsumer (), - youngest = ref TStamp.ancient } - - val al_managers = - AutoLoad.mkManagers { get_ginfo = al_ginfo, - dropPickles = dropPickles } - - fun reset () = - (Compile.reset (); - Link.reset (); - AutoLoad.reset (); - Parse.reset (); - SmlInfo.reset (); - StabModmap.reset ()) - - fun initTheValues (bootdir, de, er, autoload_postprocess, icm) = let - (* icm: "install compilation manager" *) - val _ = let - fun listDir ds = let - fun loop l = - case F.readDir ds of - NONE => l - | SOME x => loop (x :: l) - in - loop [] - end - val fileList = SafeIO.perform - { openIt = fn () => F.openDir bootdir, - closeIt = F.closeDir, - work = listDir, - cleanup = fn _ => () } - fun isDir x = F.isDir x handle _ => false - fun subDir x = let - val d = P.concat (bootdir, x) - in - if isDir d then SOME (x, d) else NONE - end - val pairList = List.mapPartial subDir fileList - fun sa (x, d) = SrcPath.set_anchor (penv, x, SOME d) - in - app sa pairList - end - - val pidmapfile = P.concat (bootdir, BtNames.pidmap) - - fun readpidmap s = let - fun loop m = let - fun enter (d, pids) = let - fun enter1 (spec, pm) = let - val fromHex = PersStamps.fromHex - in - case String.tokens (fn c => c = #":") spec of - [pos, hexp] => - (case (fromHex hexp, Int.fromString pos) of - (SOME p, SOME i) => - (case DE.look de p of - NONE => pm - | SOME obj => - IM.insert (pm, i, - DE.singleton (p, obj))) - | _ => pm) - | _ => pm - end - in - SrcPathMap.insert (m, SrcPath.decode penv d, - foldl enter1 IM.empty pids) - end - in - case TextIO.inputLine s of - NONE => m - | SOME line => - (case String.tokens Char.isSpace line of - d :: pids => loop (enter (d, pids)) - | _ => loop m) - end - val m = loop SrcPathMap.empty - in - system_values := m - end - - val _ = - SafeIO.perform { openIt = fn () => TextIO.openIn pidmapfile, - closeIt = TextIO.closeIn, - work = readpidmap, - cleanup = fn _ => () } - - val initgspec = mkStdSrcPath BtNames.initgspec - val ginfo = { param = { fnpolicy = fnpolicy, - penv = penv, - symval = SSV.symval, - archos = my_archos, - keep_going = false, - slave_mode = false }, - groupreg = GroupReg.new (), - errcons = EM.defaultConsumer (), - youngest = ref TStamp.ancient } - fun loadInitGroup () = - Stabilize.loadStable - { getGroup = fn _ => - raise Fail "CMBoot: initial getGroup", - anyerrors = ref false } - (ginfo, initgspec, NONE, []) - in - case loadInitGroup () of - NONE => raise Fail "CMBoot: unable to load init group" - | SOME init_group => let - val _ = Compile.reset () - val _ = Link.reset () - - val { exports = ctm, ... } = - Compile.newTraversal (fn _ => fn _ => (), - fn _ => (), - init_group) - val { exports = ltm, ... } = Link.newTraversal - (init_group, fn _ => raise Fail "init: get bfc?") - - fun getSymTrav (tr_m, sy) = - case SymbolMap.find (tr_m, sy) of - NONE => raise Fail "init: bogus init group (1)" - | SOME tr => tr - - val perv_ct = getSymTrav (ctm, PervAccess.pervStrSym) - val perv_lt = getSymTrav (ltm, PervAccess.pervStrSym) - - fun doTrav t = - case t ginfo of - SOME r => r - | NONE => raise Fail "init: bogus init group (2)" - - val { stat = pervstat, sym = pervsym } = doTrav perv_ct - val pervdyn = doTrav perv_lt - - val pervasive = E.mkenv { static = pervstat, - symbolic = pervsym, - dynamic = pervdyn } - - fun bare_autoload x = - (Say.say - ["!* ", x, - ": \"autoload\" not available, using \"make\"\n"]; - makeStd x) - val bare_preload = Preload.preload { - make = makeStd, - autoload = bare_autoload - } - val standard_preload = Preload.preload { - make = makeStd, - autoload = autoload mkStdSrcPath - } - in - #set ER.pervasive pervasive; - #set (ER.loc ()) E.emptyEnv;(* redundant? *) - theValues := SOME { init_group = init_group }; - case er of - BARE => - (bare_preload BtNames.bare_preloads; - system_values := SrcPathMap.empty; - NONE) - | AUTOLOAD => - (icm al_managers; - standard_preload BtNames.standard_preloads; - (* unconditionally drop all library pickles *) - Parse.dropPickles (); - SOME (autoload_postprocess ())) - end - end - end - in - 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) - fun processFile (file, mk, ext) = (case ext - of ("sml" | "sig" | "fun") => useFile file - | "cm" => mk file - | _ => Say.say [ - "!* unable to process '", file, "' (unknown extension '", ext, "')\n" - ] - (* end case *)) - - (* DAYA change starts here *) - 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 - (* DAYA change ends here *) - - fun inc n = n + 1 - fun show_controls (getarg, getval, padval) level = let - fun walk indent (ControlRegistry.RTree rt) = let - open FormatComb - val { help, ctls, subregs, path } = rt - - fun one ci = let - val arg = concat (foldr (fn (s, r) => s :: "." :: r) - [getarg ci] path) - val value = getval ci - val sz = size value - val lw = !Control_Print.linewidth - val padsz = lw - 6 - size arg - indent - in - if padsz < sz then - let val padsz' = Int.max (lw, sz + 8 + indent) - in - format' Say.say (sp (indent + 6) o - text arg o nl o - padval padsz' (text value) o - nl) - end - else format' Say.say (sp (indent + 6) o - text arg o - padval padsz (text value) o - nl) - end - in - case (ctls, subregs) of - ([], []) => () - | _ => (format' Say.say - (sp indent o text help o text ":" o nl); - app one ctls; - app (walk (indent + 1)) subregs) - end - in - walk 2 (ControlRegistry.controls - (BasicControl.topregistry, Option.map inc level)) - end - - (* !!Important!! - * This message should be kept in sync with the manpage (doc/src/man/sml.1.txt) - *) - fun help level = (Say.say [ - "\ - \sml [rtsargs] [options] [files]\n\ - \\n\ - \ rtsargs:\n\ - \ @SMLversion (echo the version of SML/NJ then exit)\n\ - \ @SMLwordsize (echo the wordsze for the system then exit)\n\ - \ @SMLsuffix (echo the heap suffix for the system then exit)\n\ - \ @SMLload= (load specified heap image)\n\ - \ @SMLcmdname= (set command name)\n\ - \ @SMLalloc= (specify size of allocation area)\n\ - \ @SMLrun= (specify runtime system)\n\ - \ @SMLquiet (load heap image silently)\n\ - \ @SMLverbose (show heap image load progress)\n\ - \ @SMLobjects (show list of executable objects)\n\ - \ @SMLdebug= (write debugging info to file)\n\ - \\n\ - \ options:\n\ - \ -D= (set CM variable to given value)\n\ - \ -D (set CM variable to 1)\n\ - \ -Uname (unset CM variable)\n\ - \ -C= (set named control)\n\ - \ -H (produce complete help listing)\n\ - \ -h (produce minimal help listing)\n\ - \ -h (help with obscurity limit)\n\ - \ -S (list all current settings)\n\ - \ -s (limited list of settings)\n\ - \ -E (list all environment variables)\n\ - \ -e (list limited list of environment variables)\n\n\ - \\n\ - \ files:\n\ - \ .cm (CM.make or CM.autoload)\n\ - \ -m (switch to CM.make)\n\ - \ -a (switch to CM.autoload; default)\n\ - \ --script (execute scripts)\n\ - \ .sig (use)\n\ - \ .sml (use)\n\ - \ .fun (use)\n\ - \" - ]; - show_controls (Controls.name o #ctl, - fn ci => - concat ["(", #help (Controls.info (#ctl ci)), - ")"], - FormatComb.pad FormatComb.left) - level) - - fun showcur level = - show_controls (fn ci => (Controls.name (#ctl ci) ^ "="), - fn ci => Controls.get (#ctl ci), - fn _ => fn ff => ff) - level - - fun show_envvars level = - show_controls (fn ci => (Controls.name (#ctl ci) ^ ":"), - fn ci => Option.getOpt (#envName (#info ci), - "(none)"), - FormatComb.pad FormatComb.left) - level - - fun badopt opt f () = - Say.say ["!* bad ", opt, " option: `", f, "'\n", - "!* try `-h' or `-h' for help\n"] - - fun quit () = OS.Process.exit OS.Process.success - - fun quit_if true = quit () - | quit_if false = () - - fun carg (opt as ("-C" | "-D"), f, _, _) = - let val bad = badopt opt f - val spec = Substring.extract (f, 2, NONE) - val is_config = opt = "-C" - val (name, value) = - Substring.splitl (fn c => c <> #"=") spec - val name = Substring.string name - val value = Substring.string - (if Substring.size value > 0 then - Substring.slice (value, 1, NONE) - else value) - in - if name = "" then bad () - else if is_config then - let val names = String.fields (fn c => c = #".") name - val look = ControlRegistry.control - BasicControl.topregistry - in - case look names of - NONE => Say.say ["!* no such control: ", - name, "\n"] - | SOME sctl => - (Controls.set (sctl, value) - handle Controls.ValueSyntax vse => - Say.say ["!* unable to parse value `", - #value vse, "' for ", - #ctlName vse, " : ", - #tyName vse, "\n"]) - end - else if value = "" then #set (SSV.symval name) (SOME 1) - else (case Int.fromString value of - SOME i => #set (SSV.symval name) (SOME i) - | NONE => bad ()) - end - | carg ("-U", f, _, _) = - (case String.extract (f, 2, NONE) of - "" => badopt "-U" f () - | var => #set (SSV.symval var) NONE) - | carg ("-h", f, _, last) = - (case String.extract (f, 2, NONE) of - "" => help (SOME 0) - | level => help (Int.fromString level); - quit_if last) - | carg ("-s", f, _, last) = - (case String.extract (f, 2, NONE) of - "" => showcur (SOME 0) - | level => showcur (Int.fromString level); - quit_if last) - | carg ("-e", f, _, last) = - (case String.extract (f, 2, NONE) of - "" => show_envvars (SOME 0) - | level => show_envvars (Int.fromString level); - quit_if last) - | carg (_, f, mk, _) = - processFile (f, mk, String.map Char.toLower - (getOpt (OS.Path.ext f, ""))) - - fun args ([], _) = () - | args ("-a" :: _, _) = nextarg autoload' - | args ("-m" :: _, _) = nextarg make' - | args (["-H"], _) = (help NONE; quit ()) - | args ("-H" :: _ :: _, mk) = (help NONE; nextarg mk) - | args (["-S"], _) = (showcur NONE; quit ()) - | args ("-S" :: _ :: _, mk) = (showcur NONE; nextarg mk) - | args (["-E"], _) = (show_envvars NONE; quit ()) - | args ("-E" :: _ :: _, mk) = (show_envvars NONE; nextarg mk) - | args ("--script" :: _, _) = (nextargscript ()) (* line added by Daya HWU *) - | args ("@CMbuild" :: rest, _) = mlbuild rest - | args (["@CMredump", heapfile], _) = redump_heap heapfile - | args (f :: rest, mk) = - (carg (String.substring (f, 0, 2) - handle General.Subscript => "", - f, mk, List.null rest); - nextarg mk) - - and nextarg mk = - let val l = SMLofNJ.getArgs () - in SMLofNJ.shiftArgs (); args (l, mk) - end - - (* nextargscript added by Daya HWU *) - 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 ()) - | l => (SMLofNJ.shiftArgs (); args (l, autoload')) - end - in - useStreamHook := useStream; - initTheValues (bootdir, de, er, - fn () => (Cleanup.install initPaths; - procCmdLine), - icm) - end - - structure CM = struct - type 'a controller = { get : unit -> 'a, set : 'a -> unit } - - structure Anchor = struct - fun anchor a = { get = getAnchor a, set = setAnchor a } - val reset = resetPathConfig - end - - structure Control = struct - val keep_going = StdConfig.keep_going - val verbose = StdConfig.verbose - val parse_caching = StdConfig.parse_caching - val warn_obsolete = StdConfig.warn_obsolete - val debug = StdConfig.debug - val conserve_memory = StdConfig.conserve_memory - val generate_index = StdConfig.generate_index - end - - structure Library = struct - type lib = SrcPath.file - val known = Parse.listLibs - val descr = SrcPath.descr - val osstring = SrcPath.osstring - val dismiss = Parse.dismissLib - fun unshare lib = (Link.unshare lib; dismiss lib) - end - - structure State = struct - val synchronize = SrcPath.sync - val reset = reset - val pending = getPending - val showBindings = showBindings - end - - structure Server = struct - type server = Servers.server_handle - fun start x = Servers.start x - before SrcPath.scheduleNotification () - val stop = Servers.stop - val kill = Servers.kill - val name = Servers.name - end - - (* note that we use the "standard" path syntax during the bootstrapping - * process, but switch to native paths for the use of CM in the REPL. - *) - val autoload = autoload mkNativeSrcPath - val make = makeNative - val recomp = recomp mkNativeSrcPath - val stabilize = stabilize mkNativeSrcPath - - val sources = sources - - val symval = SSV.symval - val load_plugin = cwd_load_plugin - val mk_standalone = mk_standalone - - structure Graph = struct - val graph = to_portable - end - - val cm_dir_arc = FilenamePolicy.cm_dir_arc - - val redump_heap = redump_heap - end - - structure Tools = ToolsFn (val load_plugin' = load_plugin' - val penv = penv) - - val load_plugin = load_plugin - end -end (* end functor *) From 0563403834fd0517c0a41d48d0a2e99d27b5ea7c Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sat, 15 Apr 2023 18:21:58 +0100 Subject: [PATCH 3/9] Add files via upload MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit Changes made in cm-boot.sml to recognise the new command line parameter passed from script. a) In function args, line added to recognise the new command-line parameter ‘--script’, and a new function ‘nextargscript’ is called to initiate the process of the file. b) In function init(), the new function (useScriptFile) is added as one of the parameter passed. c) In function procCmdLine (), new function processFileScript is added to process the script file, function will check for whether the file passed on is a script file starting with ‘#!’ thru another new function checkSharpbang, consumes the first line thru another new function eatuntilneline and pass the remaining content of the file to function useScriptFile. --- base/cm/main/cm-boot.sml | 46 +++++++++++++++++++++++++++++++++++++++- 1 file changed, 45 insertions(+), 1 deletion(-) diff --git a/base/cm/main/cm-boot.sml b/base/cm/main/cm-boot.sml index 46202add..e9c19718 100644 --- a/base/cm/main/cm-boot.sml +++ b/base/cm/main/cm-boot.sml @@ -690,7 +690,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct end end in - fun init (bootdir, de, er, useStream, useFile, errorwrap, icm) = let + 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 +701,41 @@ functor LinkCM (structure HostBackend : BACKEND) = struct "!* unable to process '", file, "' (unknown extension '", ext, "')\n" ] (* end case *)) + + (* DAYA change starts here *) + 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 + (* DAYA 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 +813,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 scripts)\n\ \ .sig (use)\n\ \ .sml (use)\n\ \ .fun (use)\n\ @@ -878,6 +914,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 ()) (* line added by Daya HWU *) | args ("@CMbuild" :: rest, _) = mlbuild rest | args (["@CMredump", heapfile], _) = redump_heap heapfile | args (f :: rest, mk) = @@ -890,6 +927,13 @@ functor LinkCM (structure HostBackend : BACKEND) = struct let val l = SMLofNJ.getArgs () in SMLofNJ.shiftArgs (); args (l, mk) end + + (* nextargscript added by Daya HWU *) + 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 ()) From 4b1163175eed5b70c14a640e749904b1193e3e5c Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sat, 15 Apr 2023 18:23:07 +0100 Subject: [PATCH 4/9] Add files via upload In functor BootEnvF, cminit function declaration is amended to include the newly added function useScriptFile. --- base/system/smlnj/internal/boot-env-fn.sml | 2 ++ 1 file changed, 2 insertions(+) diff --git a/base/system/smlnj/internal/boot-env-fn.sml b/base/system/smlnj/internal/boot-env-fn.sml index d9b2d1f6..b31ba97a 100644 --- a/base/system/smlnj/internal/boot-env-fn.sml +++ b/base/system/smlnj/internal/boot-env-fn.sml @@ -15,6 +15,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 *) * (string -> unit) (* useFile *) * ((string -> unit) -> (string -> unit)) (* errorwrap *) @@ -70,6 +71,7 @@ functor BootEnvF (datatype envrequest = AUTOLOAD | BARE U.pStruct := U.NILrde; cminit (bootdir, de, er, Backend.Interact.useStream, + Backend.Interact.useScriptFile, errorwrap false useFile, errorwrap true, Backend.Interact.installCompManagers) From dc9b0a6ef7fe7ef57ae0a728d8289d4e62b3e5d0 Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sat, 15 Apr 2023 18:24:03 +0100 Subject: [PATCH 5/9] Add files via upload A new function (useScriptFile) is added to Backend.Interact structure, which takes the file name and its content as a stream and process the stream by passing it to EvalLoop.evalStream. The compiler messages are muted and unmuted before the processing of the file. a) New function declaration is added to interact.sig, b) New function definition is added to interact.sml. --- base/compiler/TopLevel/interact/interact.sig | 1 + base/compiler/TopLevel/interact/interact.sml | 10 ++++++++++ 2 files changed, 11 insertions(+) diff --git a/base/compiler/TopLevel/interact/interact.sig b/base/compiler/TopLevel/interact/interact.sig index be83754c..e7af248b 100644 --- a/base/compiler/TopLevel/interact/interact.sig +++ b/base/compiler/TopLevel/interact/interact.sig @@ -27,6 +27,7 @@ signature INTERACT = val useFile : string -> bool val useStream : TextIO.instream -> unit + val useScriptFile : string * TextIO.instream -> unit (* Addded by DAYA *) 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..e6574ff1 100644 --- a/base/compiler/TopLevel/interact/interact.sml +++ b/base/compiler/TopLevel/interact/interact.sml @@ -91,6 +91,16 @@ functor Interact(EvalLoop : EVALLOOP) : INTERACT = fun useStream stream = EvalLoop.evalStream ("", stream) + (* Added by DAYA*) + + fun useScriptFile (fname, stream) = ( + + (EvalLoop.evalStream (fname, stream)) + handle exn => ( + EvalLoop.uncaughtExnMessage exn + ) + ) + fun evalStream (stream, baseEnv) = let val r = ref Environment.emptyEnv val base = { set = fn _ => raise Fail "evalStream: #set base", From 05440b93c89a6f61102b2422ae4162dd8d8a7ad2 Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sun, 16 Apr 2023 11:19:13 +0100 Subject: [PATCH 6/9] Add files via upload --- base/cm/main/cm-boot.sml | 13 +++++++------ 1 file changed, 7 insertions(+), 6 deletions(-) diff --git a/base/cm/main/cm-boot.sml b/base/cm/main/cm-boot.sml index e9c19718..b8882143 100644 --- a/base/cm/main/cm-boot.sml +++ b/base/cm/main/cm-boot.sml @@ -690,7 +690,8 @@ functor LinkCM (structure HostBackend : BACKEND) = struct end end in - fun init (bootdir, de, er, useStream, useScriptFile, 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) @@ -702,7 +703,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct ] (* end case *)) - (* DAYA change starts here *) + (* 'Execute as a script' change starts here - *) fun eatuntilnewline (instream : TextIO.instream): bool = let val c = TextIO.input1 instream in @@ -734,7 +735,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct then ( Say.say [ "!* Script file doesn't start with #!. \n" ] ) else ( useScriptFile (fname, stream) ) end - (* DAYA change ends here *) + (* 'Execute as a script' change ends here *) fun inc n = n + 1 fun show_controls (getarg, getval, padval) level = let @@ -813,7 +814,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 scripts)\n\ + \ --script (execute as a script)\n\ \ .sig (use)\n\ \ .sml (use)\n\ \ .fun (use)\n\ @@ -914,7 +915,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 ()) (* line added by Daya HWU *) + | 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) = @@ -928,7 +929,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct in SMLofNJ.shiftArgs (); args (l, mk) end - (* nextargscript added by Daya HWU *) + (* nextargscript added as part of 'Execute as a script' change *) and nextargscript () = let val l = SMLofNJ.getArgs () in SMLofNJ.shiftArgs (); processFileScript (hd l); quit () From eb1ed8e6ff442210bbb0b46943aa918661eb347d Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sun, 16 Apr 2023 11:19:51 +0100 Subject: [PATCH 7/9] Add files via upload --- base/system/smlnj/internal/boot-env-fn.sml | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/base/system/smlnj/internal/boot-env-fn.sml b/base/system/smlnj/internal/boot-env-fn.sml index b31ba97a..99f07bdb 100644 --- a/base/system/smlnj/internal/boot-env-fn.sml +++ b/base/system/smlnj/internal/boot-env-fn.sml @@ -15,7 +15,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 *) + * (string * TextIO.instream -> unit) (* useScriptFile - added as part of 'Execute as a script' change *) * (string -> unit) (* useFile *) * ((string -> unit) -> (string -> unit)) (* errorwrap *) @@ -71,7 +71,7 @@ functor BootEnvF (datatype envrequest = AUTOLOAD | BARE U.pStruct := U.NILrde; cminit (bootdir, de, er, Backend.Interact.useStream, - Backend.Interact.useScriptFile, + Backend.Interact.useScriptFile, (* added as part of Execute as a script change *) errorwrap false useFile, errorwrap true, Backend.Interact.installCompManagers) From eb5d746eb0df7f5854a7562f0d35793897cf9ae6 Mon Sep 17 00:00:00 2001 From: dn2007hw <97540697+dn2007hw@users.noreply.github.com> Date: Sun, 16 Apr 2023 11:20:23 +0100 Subject: [PATCH 8/9] Add files via upload --- base/compiler/TopLevel/interact/interact.sig | 2 +- base/compiler/TopLevel/interact/interact.sml | 3 +-- 2 files changed, 2 insertions(+), 3 deletions(-) diff --git a/base/compiler/TopLevel/interact/interact.sig b/base/compiler/TopLevel/interact/interact.sig index e7af248b..7443a21e 100644 --- a/base/compiler/TopLevel/interact/interact.sig +++ b/base/compiler/TopLevel/interact/interact.sig @@ -27,7 +27,7 @@ signature INTERACT = val useFile : string -> bool val useStream : TextIO.instream -> unit - val useScriptFile : string * TextIO.instream -> unit (* Addded by DAYA *) + 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 e6574ff1..23cfaecd 100644 --- a/base/compiler/TopLevel/interact/interact.sml +++ b/base/compiler/TopLevel/interact/interact.sml @@ -91,8 +91,7 @@ functor Interact(EvalLoop : EVALLOOP) : INTERACT = fun useStream stream = EvalLoop.evalStream ("", stream) - (* Added by DAYA*) - + (* Added as part of Execute as a script change*) fun useScriptFile (fname, stream) = ( (EvalLoop.evalStream (fname, stream)) From b1ffde382608796cbed445833922ceca5e4fe00e Mon Sep 17 00:00:00 2001 From: Dayanandan Natarajan Date: Tue, 2 May 2023 14:10:56 +0100 Subject: [PATCH 9/9] Comments included to add author info. --- base/cm/main/cm-boot.sml | 5 ++++- base/compiler/TopLevel/interact/interact.sig | 3 +++ base/compiler/TopLevel/interact/interact.sml | 5 ++++- base/system/smlnj/internal/boot-env-fn.sml | 3 +++ 4 files changed, 14 insertions(+), 2 deletions(-) diff --git a/base/cm/main/cm-boot.sml b/base/cm/main/cm-boot.sml index b8882143..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 @@ -703,7 +706,7 @@ functor LinkCM (structure HostBackend : BACKEND) = struct ] (* end case *)) - (* 'Execute as a script' change starts here - *) + (* '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 diff --git a/base/compiler/TopLevel/interact/interact.sig b/base/compiler/TopLevel/interact/interact.sig index 7443a21e..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 = diff --git a/base/compiler/TopLevel/interact/interact.sml b/base/compiler/TopLevel/interact/interact.sml index 23cfaecd..509aa5d2 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,7 +94,7 @@ functor Interact(EvalLoop : EVALLOOP) : INTERACT = fun useStream stream = EvalLoop.evalStream ("", stream) - (* Added as part of Execute as a script change*) + (* Function added as part of Execute as a script change*) fun useScriptFile (fname, stream) = ( (EvalLoop.evalStream (fname, stream)) diff --git a/base/system/smlnj/internal/boot-env-fn.sml b/base/system/smlnj/internal/boot-env-fn.sml index 99f07bdb..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: