From d51df2aef36b1b074b98da29223ca3b27f54e41a Mon Sep 17 00:00:00 2001 From: Arfon Smith Date: Mon, 23 Dec 2013 14:50:39 -0600 Subject: [PATCH] Adding .fun extension to Standard ML definition and adding some sample files --- lib/linguist/samples.json | 615 ++++++++++- samples/Standard ML/RedBlackTree.fun | 254 +++++ samples/Standard ML/main.fun | 1470 ++++++++++++++++++++++++++ 3 files changed, 2297 insertions(+), 42 deletions(-) create mode 100644 samples/Standard ML/RedBlackTree.fun create mode 100644 samples/Standard ML/main.fun diff --git a/lib/linguist/samples.json b/lib/linguist/samples.json index 73c21074..5ec8be76 100644 --- a/lib/linguist/samples.json +++ b/lib/linguist/samples.json @@ -395,6 +395,7 @@ ".nut" ], "Standard ML": [ + ".fun", ".sig", ".sml" ], @@ -519,8 +520,8 @@ ".gemrc" ] }, - "tokens_total": 433258, - "languages_total": 510, + "tokens_total": 439420, + "languages_total": 512, "tokens": { "ABAP": { "*/**": 1, @@ -43025,64 +43026,594 @@ "signature": 2, "LAZY_BASE": 3, "sig": 2, - "type": 2, - "a": 18, + "type": 5, + "a": 74, "lazy": 12, - "-": 13, - ")": 23, - "end": 6, + "-": 19, + ")": 826, + "end": 52, "LAZY": 1, - "bool": 4, - "val": 12, + "bool": 9, + "val": 143, "inject": 3, - "toString": 2, - "(": 22, - "string": 1, + "toString": 3, + "(": 822, + "string": 14, "eq": 2, - "*": 1, + "*": 9, "eqBy": 3, - "compare": 2, + "compare": 7, "order": 2, "map": 2, - "b": 2, - "structure": 6, + "b": 58, + "structure": 10, "Ops": 2, "LazyBase": 2, - "struct": 4, + "struct": 9, "exception": 1, "Undefined": 3, - "fun": 9, + "fun": 51, "delay": 3, - "f": 9, + "f": 37, "force": 9, "undefined": 1, - "fn": 3, - "raise": 1, + "fn": 124, + "raise": 5, "LazyMemoBase": 2, - "datatype": 1, - "|": 1, + "datatype": 28, + "|": 225, "Done": 1, - "of": 1, - "unit": 1, - "let": 1, - "open": 1, + "of": 90, + "unit": 6, + "let": 43, + "open": 8, "B": 1, - "x": 15, + "x": 59, "isUndefined": 2, - "ignore": 1, - ";": 1, - "false": 1, - "handle": 1, - "true": 1, - "if": 1, - "then": 1, - "else": 1, - "p": 4, - "y": 6, + "ignore": 2, + ";": 20, + "false": 31, + "handle": 3, + "true": 35, + "if": 50, + "then": 50, + "else": 50, + "p": 6, + "y": 44, "op": 1, "Lazy": 1, "LazyFn": 2, - "LazyMemo": 1 + "LazyMemo": 1, + "functor": 2, + "Main": 1, + "S": 2, + "MAIN_STRUCTS": 1, + "MAIN": 1, + "Compile": 3, + "Place": 1, + "t": 23, + "Files": 3, + "Generated": 4, + "MLB": 4, + "O": 4, + "OUT": 3, + "SML": 6, + "TypeCheck": 3, + "toInt": 1, + "int": 1, + "OptPred": 1, + "Target": 1, + "Yes": 1, + "Show": 1, + "Anns": 1, + "PathMap": 1, + "gcc": 5, + "ref": 45, + "arScript": 3, + "asOpts": 6, + "{": 79, + "opt": 34, + "pred": 15, + "OptPred.t": 3, + "}": 79, + "list": 10, + "[": 104, + "]": 108, + "ccOpts": 6, + "linkOpts": 6, + "buildConstants": 2, + "debugRuntime": 3, + "debugFormat": 5, + "Dwarf": 3, + "DwarfPlus": 3, + "Dwarf2": 3, + "Stabs": 3, + "StabsPlus": 3, + "option": 6, + "NONE": 47, + "expert": 3, + "explicitAlign": 3, + "Control.align": 1, + "explicitChunk": 2, + "Control.chunk": 1, + "explicitCodegen": 5, + "Native": 5, + "Explicit": 5, + "Control.codegen": 3, + "keepGenerated": 3, + "keepO": 3, + "output": 16, + "profileSet": 3, + "profileTimeSet": 3, + "runtimeArgs": 3, + "show": 2, + "Show.t": 1, + "stop": 10, + "Place.OUT": 1, + "parseMlbPathVar": 3, + "line": 9, + "String.t": 1, + "case": 83, + "String.tokens": 7, + "Char.isSpace": 8, + "var": 3, + "path": 7, + "SOME": 68, + "_": 83, + "readMlbPathMap": 2, + "file": 14, + "File.t": 12, + "not": 1, + "File.canRead": 1, + "Error.bug": 14, + "concat": 52, + "List.keepAllMap": 4, + "File.lines": 2, + "String.forall": 4, + "v": 4, + "targetMap": 5, + "arch": 11, + "MLton.Platform.Arch.t": 3, + "os": 13, + "MLton.Platform.OS.t": 3, + "target": 28, + "Promise.lazy": 1, + "targetsDir": 5, + "OS.Path.mkAbsolute": 4, + "relativeTo": 4, + "Control.libDir": 1, + "potentialTargets": 2, + "Dir.lsDirs": 1, + "targetDir": 5, + "osFile": 2, + "OS.Path.joinDirFile": 3, + "dir": 4, + "archFile": 2, + "File.contents": 2, + "List.first": 2, + "MLton.Platform.OS.fromString": 1, + "MLton.Platform.Arch.fromString": 1, + "in": 40, + "setTargetType": 3, + "usage": 48, + "List.peek": 7, + "...": 23, + "Control": 3, + "Target.arch": 2, + "Target.os": 2, + "hasCodegen": 8, + "cg": 21, + "z": 73, + "Control.Target.arch": 4, + "Control.Target.os": 2, + "Control.Format.t": 1, + "AMD64": 2, + "x86Codegen": 9, + "X86": 3, + "amd64Codegen": 8, + "<": 3, + "Darwin": 6, + "orelse": 7, + "Control.format": 3, + "Executable": 5, + "Archive": 4, + "hasNativeCodegen": 2, + "defaultAlignIs8": 3, + "Alpha": 1, + "ARM": 1, + "HPPA": 1, + "IA64": 1, + "MIPS": 1, + "Sparc": 1, + "S390": 1, + "makeOptions": 3, + "s": 168, + "Fail": 2, + "reportAnnotation": 4, + "flag": 12, + "e": 18, + "Control.Elaborate.Bad": 1, + "Control.Elaborate.Deprecated": 1, + "ids": 2, + "Control.warnDeprecated": 1, + "Out.output": 2, + "Out.error": 3, + "List.toString": 1, + "Control.Elaborate.Id.name": 1, + "Control.Elaborate.Good": 1, + "Control.Elaborate.Other": 1, + "Popt": 1, + "tokenizeOpt": 4, + "opts": 4, + "List.foreach": 5, + "tokenizeTargetOpt": 4, + "List.map": 3, + "Normal": 29, + "SpaceString": 48, + "Align4": 2, + "Align8": 2, + "Expert": 72, + "o": 8, + "List.push": 22, + "OptPred.Yes": 6, + "boolRef": 20, + "ChunkPerFunc": 1, + "OneChunk": 1, + "String.hasPrefix": 2, + "prefix": 3, + "String.dropPrefix": 1, + "Char.isDigit": 3, + "Int.fromString": 4, + "n": 4, + "Coalesce": 1, + "limit": 1, + "Bool": 10, + "closureConvertGlobalize": 1, + "closureConvertShrink": 1, + "String.concatWith": 2, + "Control.Codegen.all": 2, + "Control.Codegen.toString": 2, + "name": 7, + "value": 4, + "Compile.setCommandLineConstant": 2, + "contifyIntoMain": 1, + "debug": 4, + "Control.Elaborate.processDefault": 1, + "Control.defaultChar": 1, + "Control.defaultInt": 5, + "Control.defaultReal": 2, + "Control.defaultWideChar": 2, + "Control.defaultWord": 4, + "Regexp.fromString": 7, + "re": 34, + "Regexp.compileDFA": 4, + "diagPasses": 1, + "Control.Elaborate.processEnabled": 2, + "dropPasses": 1, + "intRef": 8, + "errorThreshhold": 1, + "emitMain": 1, + "exportHeader": 3, + "Control.Format.all": 2, + "Control.Format.toString": 2, + "gcCheck": 1, + "Limit": 1, + "First": 1, + "Every": 1, + "Native.IEEEFP": 1, + "indentation": 1, + "Int": 8, + "i": 8, + "inlineNonRec": 6, + "small": 19, + "product": 19, + "#product": 1, + "inlineIntoMain": 1, + "loops": 18, + "inlineLeafA": 6, + "repeat": 18, + "size": 19, + "inlineLeafB": 6, + "keepCoreML": 1, + "keepDot": 1, + "keepMachine": 1, + "keepRSSA": 1, + "keepSSA": 1, + "keepSSA2": 1, + "keepSXML": 1, + "keepXML": 1, + "keepPasses": 1, + "libname": 9, + "loopPasses": 1, + "Int.toString": 3, + "markCards": 1, + "maxFunctionSize": 1, + "mlbPathVars": 4, + "@": 3, + "Native.commented": 1, + "Native.copyProp": 1, + "Native.cutoff": 1, + "Native.liveTransfer": 1, + "Native.liveStack": 1, + "Native.moveHoist": 1, + "Native.optimize": 1, + "Native.split": 1, + "Native.shuffle": 1, + "err": 1, + "optimizationPasses": 1, + "il": 10, + "set": 10, + "Result.Yes": 6, + "Result.No": 5, + "polyvariance": 9, + "hofo": 12, + "rounds": 12, + "preferAbsPaths": 1, + "profPasses": 1, + "profile": 6, + "ProfileNone": 2, + "ProfileAlloc": 1, + "ProfileCallStack": 3, + "ProfileCount": 1, + "ProfileDrop": 1, + "ProfileLabel": 1, + "ProfileTimeLabel": 4, + "ProfileTimeField": 2, + "profileBranch": 1, + "Regexp": 3, + "seq": 3, + "anys": 6, + "compileDFA": 3, + "profileC": 1, + "profileInclExcl": 2, + "profileIL": 3, + "ProfileSource": 1, + "ProfileSSA": 1, + "ProfileSSA2": 1, + "profileRaise": 2, + "profileStack": 1, + "profileVal": 1, + "Show.Anns": 1, + "Show.PathMap": 1, + "showBasis": 1, + "showDefUse": 1, + "showTypes": 1, + "Control.optimizationPasses": 4, + "String.equals": 4, + "Place.Files": 2, + "Place.Generated": 2, + "Place.O": 3, + "Place.TypeCheck": 1, + "#target": 2, + "Self": 2, + "Cross": 2, + "SpaceString2": 6, + "OptPred.Target": 6, + "#1": 1, + "trace": 4, + "#2": 2, + "typeCheck": 1, + "verbosity": 4, + "Silent": 3, + "Top": 5, + "Pass": 1, + "Detail": 1, + "warnAnn": 1, + "warnDeprecated": 1, + "zoneCutDepth": 1, + "style": 6, + "arg": 3, + "desc": 3, + "mainUsage": 3, + "parse": 2, + "Popt.makeUsage": 1, + "showExpert": 1, + "commandLine": 5, + "args": 8, + "lib": 2, + "libDir": 2, + "OS.Path.mkCanonical": 1, + "result": 1, + "targetStr": 3, + "libTargetDir": 1, + "targetArch": 4, + "archStr": 1, + "String.toLower": 2, + "MLton.Platform.Arch.toString": 2, + "targetOS": 5, + "OSStr": 2, + "MLton.Platform.OS.toString": 1, + "positionIndependent": 3, + "format": 7, + "MinGW": 4, + "Cygwin": 4, + "Library": 6, + "LibArchive": 3, + "Control.positionIndependent": 1, + "align": 1, + "codegen": 4, + "CCodegen": 1, + "MLton.Rusage.measureGC": 1, + "exnHistory": 1, + "Bool.toString": 1, + "Control.profile": 1, + "Control.ProfileCallStack": 1, + "sizeMap": 1, + "Control.libTargetDir": 1, + "ty": 4, + "Bytes.toBits": 1, + "Bytes.fromInt": 1, + "lookup": 4, + "use": 2, + "on": 1, + "must": 1, + "x86": 1, + "with": 1, + "ieee": 1, + "fp": 1, + "can": 1, + "No": 1, + "Out.standard": 1, + "input": 22, + "rest": 3, + "inputFile": 1, + "File.base": 5, + "File.fileOf": 1, + "start": 6, + "base": 3, + "rec": 1, + "loop": 3, + "suf": 14, + "hasNum": 2, + "sufs": 2, + "String.hasSuffix": 2, + "suffix": 8, + "Place.t": 1, + "List.exists": 1, + "File.withIn": 1, + "csoFiles": 1, + "Place.compare": 1, + "GREATER": 5, + "Place.toString": 2, + "EQUAL": 5, + "LESS": 5, + "printVersion": 1, + "tempFiles": 3, + "tmpDir": 2, + "tmpVar": 2, + "default": 2, + "MLton.Platform.OS.host": 2, + "Process.getEnv": 1, + "d": 32, + "temp": 3, + "out": 9, + "File.temp": 1, + "OS.Path.concat": 1, + "Out.close": 2, + "maybeOut": 10, + "maybeOutBase": 4, + "File.extension": 3, + "outputBase": 2, + "ext": 1, + "OS.Path.splitBaseExt": 1, + "defLibname": 6, + "OS.Path.splitDirFile": 1, + "String.extract": 1, + "toAlNum": 2, + "c": 42, + "Char.isAlphaNum": 1, + "#": 3, + "CharVector.map": 1, + "atMLtons": 1, + "Vector.fromList": 1, + "tokenize": 1, + "rev": 2, + "gccDebug": 3, + "asDebug": 2, + "compileO": 3, + "inputs": 7, + "libOpts": 2, + "System.system": 4, + "List.concat": 4, + "linkArchives": 1, + "String.contains": 1, + "File.move": 1, + "from": 1, + "to": 1, + "mkOutputO": 3, + "Counter.t": 3, + "File.dirOf": 2, + "Counter.next": 1, + "compileC": 2, + "debugSwitches": 2, + "compileS": 2, + "compileCSO": 1, + "List.forall": 1, + "Counter.new": 1, + "oFiles": 2, + "List.fold": 1, + "ac": 4, + "extension": 6, + "Option.toString": 1, + "mkCompileSrc": 1, + "listFiles": 2, + "elaborate": 1, + "compile": 2, + "outputs": 2, + "r": 3, + "make": 1, + "Int.inc": 1, + "Out.openOut": 1, + "print": 4, + "outputHeader": 2, + "done": 3, + "Control.No": 1, + "l": 2, + "Layout.output": 1, + "Out.newline": 1, + "Vector.foreach": 1, + "String.translate": 1, + "/": 1, + "Type": 1, + "Check": 1, + ".c": 1, + ".s": 1, + "invalid": 1, + "MLton": 1, + "Exn.finally": 1, + "File.remove": 1, + "doit": 1, + "Process.makeCommandLine": 1, + "main": 1, + "mainWrapped": 1, + "OS.Process.exit": 1, + "CommandLine.arguments": 1, + "RedBlackTree": 1, + "key": 16, + "entry": 12, + "dict": 17, + "Empty": 15, + "Red": 41, + "local": 1, + "lk": 4, + "tree": 4, + "and": 2, + "zipper": 3, + "TOP": 5, + "LEFTB": 10, + "RIGHTB": 10, + "delete": 3, + "zip": 19, + "Black": 40, + "LEFTR": 8, + "RIGHTR": 9, + "bbZip": 28, + "w": 17, + "delMin": 8, + "Match": 1, + "joinRed": 3, + "needB": 2, + "del": 8, + "NotFound": 2, + "entry1": 16, + "as": 7, + "key1": 8, + "datum1": 4, + "joinBlack": 1, + "insertShadow": 3, + "datum": 1, + "oldEntry": 7, + "ins": 8, + "left": 10, + "right": 10, + "restore_left": 1, + "restore_right": 1, + "app": 3, + "ap": 7, + "new": 1, + "insert": 2, + "table": 14, + "clear": 1 }, "Stylus": { "border": 6, @@ -46420,7 +46951,7 @@ "Shell": 3744, "Slash": 187, "Squirrel": 130, - "Standard ML": 243, + "Standard ML": 6405, "Stylus": 76, "SuperCollider": 133, "Tea": 3, @@ -46558,7 +47089,7 @@ "Shell": 37, "Slash": 1, "Squirrel": 1, - "Standard ML": 2, + "Standard ML": 4, "Stylus": 1, "SuperCollider": 1, "Tea": 1, @@ -46581,5 +47112,5 @@ "Xtend": 2, "YAML": 1 }, - "md5": "7e620b4e65449c0d0b3888915e319e83" + "md5": "93c72954f6d844ab0e6888ec8cdba4cb" } \ No newline at end of file diff --git a/samples/Standard ML/RedBlackTree.fun b/samples/Standard ML/RedBlackTree.fun new file mode 100644 index 00000000..42650efe --- /dev/null +++ b/samples/Standard ML/RedBlackTree.fun @@ -0,0 +1,254 @@ +(* From Twelf *) +(* Red/Black Trees *) +(* Author: Frank Pfenning *) + +functor RedBlackTree + (type key' + val compare : key' * key' -> order) + :> TABLE where type key = key' = +struct + type key = key' + type 'a entry = key * 'a + + datatype 'a dict = + Empty (* considered black *) + | Red of 'a entry * 'a dict * 'a dict + | Black of 'a entry * 'a dict * 'a dict + + type 'a Table = 'a dict ref + + (* Representation Invariants *) + (* + 1. The tree is ordered: for every node Red((key1,datum1), left, right) or + Black ((key1,datum1), left, right), every key in left is less than + key1 and every key in right is greater than key1. + + 2. The children of a red node are black (color invariant). + + 3. Every path from the root to a leaf has the same number of + black nodes, called the black height of the tree. + *) + + local + + fun lookup dict key = + let + fun lk (Empty) = NONE + | lk (Red tree) = lk' tree + | lk (Black tree) = lk' tree + and lk' ((key1, datum1), left, right) = + (case compare(key,key1) + of EQUAL => SOME(datum1) + | LESS => lk left + | GREATER => lk right) + in + lk dict + end + + (* val restore_right : 'a dict -> 'a dict *) + (* + restore_right (Black(e,l,r)) >=> dict + where (1) Black(e,l,r) is ordered, + (2) Black(e,l,r) has black height n, + (3) color invariant may be violated at the root of r: + one of its children might be red. + and dict is a re-balanced red/black tree (satisfying all invariants) + and same black height n. + *) + fun restore_right (Black(e, Red lt, Red (rt as (_,Red _,_)))) = + Red(e, Black lt, Black rt) (* re-color *) + | restore_right (Black(e, Red lt, Red (rt as (_,_,Red _)))) = + Red(e, Black lt, Black rt) (* re-color *) + | restore_right (Black(e, l, Red(re, Red(rle, rll, rlr), rr))) = + (* l is black, deep rotate *) + Black(rle, Red(e, l, rll), Red(re, rlr, rr)) + | restore_right (Black(e, l, Red(re, rl, rr as Red _))) = + (* l is black, shallow rotate *) + Black(re, Red(e, l, rl), rr) + | restore_right dict = dict + + (* restore_left is like restore_right, except *) + (* the color invariant may be violated only at the root of left child *) + fun restore_left (Black(e, Red (lt as (_,Red _,_)), Red rt)) = + Red(e, Black lt, Black rt) (* re-color *) + | restore_left (Black(e, Red (lt as (_,_,Red _)), Red rt)) = + Red(e, Black lt, Black rt) (* re-color *) + | restore_left (Black(e, Red(le, ll as Red _, lr), r)) = + (* r is black, shallow rotate *) + Black(le, ll, Red(e, lr, r)) + | restore_left (Black(e, Red(le, ll, Red(lre, lrl, lrr)), r)) = + (* r is black, deep rotate *) + Black(lre, Red(le, ll, lrl), Red(e, lrr, r)) + | restore_left dict = dict + + fun insert (dict, entry as (key,datum)) = + let + (* val ins : 'a dict -> 'a dict inserts entry *) + (* ins (Red _) may violate color invariant at root *) + (* ins (Black _) or ins (Empty) will be red/black tree *) + (* ins preserves black height *) + fun ins (Empty) = Red(entry, Empty, Empty) + | ins (Red(entry1 as (key1, datum1), left, right)) = + (case compare(key,key1) + of EQUAL => Red(entry, left, right) + | LESS => Red(entry1, ins left, right) + | GREATER => Red(entry1, left, ins right)) + | ins (Black(entry1 as (key1, datum1), left, right)) = + (case compare(key,key1) + of EQUAL => Black(entry, left, right) + | LESS => restore_left (Black(entry1, ins left, right)) + | GREATER => restore_right (Black(entry1, left, ins right))) + in + case ins dict + of Red (t as (_, Red _, _)) => Black t (* re-color *) + | Red (t as (_, _, Red _)) => Black t (* re-color *) + | dict => dict + end + + (* function below from .../smlnj-lib/Util/int-redblack-set.sml *) + (* Need to check and improve some time *) + (* Sun Mar 13 08:22:53 2005 -fp *) + + (* Remove an item. Returns true if old item found, false otherwise *) + local + exception NotFound + datatype 'a zipper + = TOP + | LEFTB of ('a entry * 'a dict * 'a zipper) + | LEFTR of ('a entry * 'a dict * 'a zipper) + | RIGHTB of ('a dict * 'a entry * 'a zipper) + | RIGHTR of ('a dict * 'a entry * 'a zipper) + in + fun delete t key = + let + fun zip (TOP, t) = t + | zip (LEFTB(x, b, z), a) = zip(z, Black(x, a, b)) + | zip (LEFTR(x, b, z), a) = zip(z, Red(x, a, b)) + | zip (RIGHTB(a, x, z), b) = zip(z, Black(x, a, b)) + | zip (RIGHTR(a, x, z), b) = zip(z, Red(x, a, b)) + (* bbZip propagates a black deficit up the tree until either the top + * is reached, or the deficit can be covered. It returns a boolean + * that is true if there is still a deficit and the zipped tree. + *) + fun bbZip (TOP, t) = (true, t) + | bbZip (LEFTB(x, Red(y, c, d), z), a) = (* case 1L *) + bbZip (LEFTR(x, c, LEFTB(y, d, z)), a) + | bbZip (LEFTB(x, Black(w, Red(y, c, d), e), z), a) = (* case 3L *) + bbZip (LEFTB(x, Black(y, c, Red(w, d, e)), z), a) + | bbZip (LEFTR(x, Black(w, Red(y, c, d), e), z), a) = (* case 3L *) + bbZip (LEFTR(x, Black(y, c, Red(w, d, e)), z), a) + | bbZip (LEFTB(x, Black(y, c, Red(w, d, e)), z), a) = (* case 4L *) + (false, zip (z, Black(y, Black(x, a, c), Black(w, d, e)))) + | bbZip (LEFTR(x, Black(y, c, Red(w, d, e)), z), a) = (* case 4L *) + (false, zip (z, Red(y, Black(x, a, c), Black(w, d, e)))) + | bbZip (LEFTR(x, Black(y, c, d), z), a) = (* case 2L *) + (false, zip (z, Black(x, a, Red(y, c, d)))) + | bbZip (LEFTB(x, Black(y, c, d), z), a) = (* case 2L *) + bbZip (z, Black(x, a, Red(y, c, d))) + | bbZip (RIGHTB(Red(y, c, d), x, z), b) = (* case 1R *) + bbZip (RIGHTR(d, x, RIGHTB(c, y, z)), b) + | bbZip (RIGHTR(Red(y, c, d), x, z), b) = (* case 1R *) + bbZip (RIGHTR(d, x, RIGHTB(c, y, z)), b) + | bbZip (RIGHTB(Black(y, Red(w, c, d), e), x, z), b) = (* case 3R *) + bbZip (RIGHTB(Black(w, c, Red(y, d, e)), x, z), b) + | bbZip (RIGHTR(Black(y, Red(w, c, d), e), x, z), b) = (* case 3R *) + bbZip (RIGHTR(Black(w, c, Red(y, d, e)), x, z), b) + | bbZip (RIGHTB(Black(y, c, Red(w, d, e)), x, z), b) = (* case 4R *) + (false, zip (z, Black(y, c, Black(x, Red(w, d, e), b)))) + | bbZip (RIGHTR(Black(y, c, Red(w, d, e)), x, z), b) = (* case 4R *) + (false, zip (z, Red(y, c, Black(w, Red(w, d, e), b)))) + | bbZip (RIGHTR(Black(y, c, d), x, z), b) = (* case 2R *) + (false, zip (z, Black(x, Red(y, c, d), b))) + | bbZip (RIGHTB(Black(y, c, d), x, z), b) = (* case 2R *) + bbZip (z, Black(x, Red(y, c, d), b)) + | bbZip (z, t) = (false, zip(z, t)) + fun delMin (Red(y, Empty, b), z) = (y, (false, zip(z, b))) + | delMin (Black(y, Empty, b), z) = (y, bbZip(z, b)) + | delMin (Black(y, a, b), z) = delMin(a, LEFTB(y, b, z)) + | delMin (Red(y, a, b), z) = delMin(a, LEFTR(y, b, z)) + | delMin (Empty, _) = raise Match + fun joinRed (Empty, Empty, z) = zip(z, Empty) + | joinRed (a, b, z) = let + val (x, (needB, b')) = delMin(b, TOP) + in + if needB + then #2(bbZip(z, Red(x, a, b'))) + else zip(z, Red(x, a, b')) + end + fun joinBlack (a, Empty, z) = #2(bbZip(z, a)) + | joinBlack (Empty, b, z) = #2(bbZip(z, b)) + | joinBlack (a, b, z) = let + val (x, (needB, b')) = delMin(b, TOP) + in + if needB + then #2(bbZip(z, Black(x, a, b'))) + else zip(z, Black(x, a, b')) + end + fun del (Empty, z) = raise NotFound + | del (Black(entry1 as (key1, datum1), a, b), z) = + (case compare(key,key1) + of EQUAL => joinBlack (a, b, z) + | LESS => del (a, LEFTB(entry1, b, z)) + | GREATER => del (b, RIGHTB(a, entry1, z))) + | del (Red(entry1 as (key1, datum1), a, b), z) = + (case compare(key,key1) + of EQUAL => joinRed (a, b, z) + | LESS => del (a, LEFTR(entry1, b, z)) + | GREATER => del (b, RIGHTR(a, entry1, z))) + in + (del(t, TOP); true) handle NotFound => false + end + end (* local *) + + (* use non-imperative version? *) + fun insertShadow (dict, entry as (key,datum)) = + let val oldEntry = ref NONE (* : 'a entry option ref *) + fun ins (Empty) = Red(entry, Empty, Empty) + | ins (Red(entry1 as (key1, datum1), left, right)) = + (case compare(key,key1) + of EQUAL => (oldEntry := SOME(entry1); + Red(entry, left, right)) + | LESS => Red(entry1, ins left, right) + | GREATER => Red(entry1, left, ins right)) + | ins (Black(entry1 as (key1, datum1), left, right)) = + (case compare(key,key1) + of EQUAL => (oldEntry := SOME(entry1); + Black(entry, left, right)) + | LESS => restore_left (Black(entry1, ins left, right)) + | GREATER => restore_right (Black(entry1, left, ins right))) + in + (oldEntry := NONE; + ((case ins dict + of Red (t as (_, Red _, _)) => Black t (* re-color *) + | Red (t as (_, _, Red _)) => Black t (* re-color *) + | dict => dict), + !oldEntry)) + end + + fun app f dict = + let fun ap (Empty) = () + | ap (Red tree) = ap' tree + | ap (Black tree) = ap' tree + and ap' (entry1, left, right) = + (ap left; f entry1; ap right) + in + ap dict + end + + in + fun new (n) = ref (Empty) (* ignore size hint *) + val insert = (fn table => fn entry => (table := insert (!table, entry))) + val insertShadow = + (fn table => fn entry => + let + val (dict, oldEntry) = insertShadow (!table, entry) + in + (table := dict; oldEntry) + end) + val lookup = (fn table => fn key => lookup (!table) key) + val delete = (fn table => fn key => (delete (!table) key; ())) + val clear = (fn table => (table := Empty)) + val app = (fn f => fn table => app f (!table)) + end + +end; (* functor RedBlackTree *) diff --git a/samples/Standard ML/main.fun b/samples/Standard ML/main.fun new file mode 100644 index 00000000..73ba50f6 --- /dev/null +++ b/samples/Standard ML/main.fun @@ -0,0 +1,1470 @@ +(* Copyright (C) 2010-2011,2013 Matthew Fluet. + * Copyright (C) 1999-2009 Henry Cejtin, Matthew Fluet, Suresh + * Jagannathan, and Stephen Weeks. + * Copyright (C) 1997-2000 NEC Research Institute. + * + * MLton is released under a BSD-style license. + * See the file MLton-LICENSE for details. + *) + +functor Main (S: MAIN_STRUCTS): MAIN = +struct + +open S + +structure Compile = Compile () + +structure Place = + struct + datatype t = Files | Generated | MLB | O | OUT | SML | TypeCheck + + val toInt: t -> int = + fn MLB => 1 + | SML => 1 + | Files => 2 + | TypeCheck => 4 + | Generated => 5 + | O => 6 + | OUT => 7 + + val toString = + fn Files => "files" + | SML => "sml" + | MLB => "mlb" + | Generated => "g" + | O => "o" + | OUT => "out" + | TypeCheck => "tc" + + fun compare (p, p') = Int.compare (toInt p, toInt p') + end + +structure OptPred = + struct + datatype t = + Target of string + | Yes + end + +structure Show = + struct + datatype t = Anns | PathMap + end + +val gcc: string ref = ref "" +val arScript: string ref = ref "" +val asOpts: {opt: string, pred: OptPred.t} list ref = ref [] +val ccOpts: {opt: string, pred: OptPred.t} list ref = ref [] +val linkOpts: {opt: string, pred: OptPred.t} list ref = ref [] + +val buildConstants: bool ref = ref false +val debugRuntime: bool ref = ref false +datatype debugFormat = Dwarf | DwarfPlus | Dwarf2 | Stabs | StabsPlus +val debugFormat: debugFormat option ref = ref NONE +val expert: bool ref = ref false +val explicitAlign: Control.align option ref = ref NONE +val explicitChunk: Control.chunk option ref = ref NONE +datatype explicitCodegen = Native | Explicit of Control.codegen +val explicitCodegen: explicitCodegen option ref = ref NONE +val keepGenerated = ref false +val keepO = ref false +val output: string option ref = ref NONE +val profileSet: bool ref = ref false +val profileTimeSet: bool ref = ref false +val runtimeArgs: string list ref = ref ["@MLton"] +val show: Show.t option ref = ref NONE +val stop = ref Place.OUT + +fun parseMlbPathVar (line: String.t) = + case String.tokens (line, Char.isSpace) of + [var, path] => SOME {var = var, path = path} + | _ => NONE + +fun readMlbPathMap (file: File.t) = + if not (File.canRead file) then + Error.bug (concat ["can't read MLB path map file: ", file]) + else + List.keepAllMap + (File.lines file, fn line => + if String.forall (line, Char.isSpace) + then NONE + else + case parseMlbPathVar line of + NONE => Error.bug (concat ["strange mlb path mapping: ", + file, ":: ", line]) + | SOME v => SOME v) + +val targetMap: unit -> {arch: MLton.Platform.Arch.t, + os: MLton.Platform.OS.t, + target: string} list = + Promise.lazy + (fn () => + let + val targetsDir = + OS.Path.mkAbsolute { path = "targets", + relativeTo = !Control.libDir } + val potentialTargets = Dir.lsDirs targetsDir + fun targetMap target = + let + val targetDir = + OS.Path.mkAbsolute { path = target, + relativeTo = targetsDir } + val osFile = + OS.Path.joinDirFile { dir = targetDir, + file = "os" } + val archFile = + OS.Path.joinDirFile { dir = targetDir, + file = "arch" } + val os = File.contents osFile + val arch = File.contents archFile + val os = List.first (String.tokens (os, Char.isSpace)) + val arch = List.first (String.tokens (arch, Char.isSpace)) + val os = + case MLton.Platform.OS.fromString os of + NONE => Error.bug (concat ["strange os: ", os]) + | SOME os => os + val arch = + case MLton.Platform.Arch.fromString arch of + NONE => Error.bug (concat ["strange arch: ", arch]) + | SOME a => a + in + SOME { arch = arch, os = os, target = target } + end + handle _ => NONE + in + List.keepAllMap (potentialTargets, targetMap) + end) + +fun setTargetType (target: string, usage): unit = + case List.peek (targetMap (), fn {target = t, ...} => target = t) of + NONE => usage (concat ["invalid target: ", target]) + | SOME {arch, os, ...} => + let + open Control + in + Target.arch := arch + ; Target.os := os + end + +fun hasCodegen (cg) = + let + datatype z = datatype Control.Target.arch + datatype z = datatype Control.Target.os + datatype z = datatype Control.Format.t + datatype z = datatype Control.codegen + in + case !Control.Target.arch of + AMD64 => (case cg of + x86Codegen => false + | _ => true) + | X86 => (case cg of + amd64Codegen => false + | x86Codegen => + (* Darwin PIC doesn't work *) + !Control.Target.os <> Darwin orelse + !Control.format = Executable orelse + !Control.format = Archive + | _ => true) + | _ => (case cg of + amd64Codegen => false + | x86Codegen => false + | _ => true) + end +fun hasNativeCodegen () = + let + datatype z = datatype Control.codegen + in + hasCodegen amd64Codegen + orelse hasCodegen x86Codegen + end + + +fun defaultAlignIs8 () = + let + datatype z = datatype Control.Target.arch + in + case !Control.Target.arch of + Alpha => true + | AMD64 => true + | ARM => true + | HPPA => true + | IA64 => true + | MIPS => true + | Sparc => true + | S390 => true + | _ => false + end + +fun makeOptions {usage} = + let + val usage = fn s => (ignore (usage s); raise Fail "unreachable") + fun reportAnnotation (s, flag, e) = + case e of + Control.Elaborate.Bad => + usage (concat ["invalid -", flag, " flag: ", s]) + | Control.Elaborate.Deprecated ids => + if !Control.warnDeprecated + then + Out.output + (Out.error, + concat ["Warning: ", "deprecated annotation: ", s, ", use ", + List.toString Control.Elaborate.Id.name ids, ".\n"]) + else () + | Control.Elaborate.Good () => () + | Control.Elaborate.Other => + usage (concat ["invalid -", flag, " flag: ", s]) + open Control Popt + datatype z = datatype MLton.Platform.Arch.t + datatype z = datatype MLton.Platform.OS.t + fun tokenizeOpt f opts = + List.foreach (String.tokens (opts, Char.isSpace), + fn opt => f opt) + fun tokenizeTargetOpt f (target, opts) = + List.foreach (String.tokens (opts, Char.isSpace), + fn opt => f (target, opt)) + in + List.map + ( + [ + (Normal, "align", if defaultAlignIs8 () then " {8|4}" else " {4|8}", + "object alignment", + (SpaceString (fn s => + explicitAlign + := SOME (case s of + "4" => Align4 + | "8" => Align8 + | _ => usage (concat ["invalid -align flag: ", + s]))))), + (Expert, "ar-script", " ", "path to a script producing archives", + SpaceString (fn s => arScript := s)), + (Normal, "as-opt", " ", "pass option to assembler", + (SpaceString o tokenizeOpt) + (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "as-opt-quote", " ", "pass (quoted) option to assembler", + SpaceString + (fn s => List.push (asOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "build-constants", " {false|true}", + "output C file that prints basis constants", + boolRef buildConstants), + (Expert, "cc", " ", "path to gcc executable", + SpaceString (fn s => gcc := s)), + (Normal, "cc-opt", " ", "pass option to C compiler", + (SpaceString o tokenizeOpt) + (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "cc-opt-quote", " ", "pass (quoted) option to C compiler", + SpaceString + (fn s => List.push (ccOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "chunkify", " {coalesce|func|one}", "set chunkify method", + SpaceString (fn s => + explicitChunk + := SOME (case s of + "func" => ChunkPerFunc + | "one" => OneChunk + | _ => let + val usage = fn () => + usage (concat ["invalid -chunkify flag: ", s]) + in + if String.hasPrefix (s, {prefix = "coalesce"}) + then let + val s = String.dropPrefix (s, 8) + in + if String.forall (s, Char.isDigit) + then (case Int.fromString s of + NONE => usage () + | SOME n => Coalesce + {limit = n}) + else usage () + end + else usage () + end))), + (Expert, "closure-convert-globalize", " {true|false}", + "whether to globalize during closure conversion", + Bool (fn b => (closureConvertGlobalize := b))), + (Expert, "closure-convert-shrink", " {true|false}", + "whether to shrink during closure conversion", + Bool (fn b => (closureConvertShrink := b))), + (Normal, "codegen", + concat [" {", + String.concatWith + (List.keepAllMap + (Native :: (List.map (Control.Codegen.all, Explicit)), + fn cg => + case cg of + Native => if hasNativeCodegen () then SOME "native" else NONE + | Explicit cg => if hasCodegen cg + then SOME (Control.Codegen.toString cg) + else NONE), + "|"), + "}"], + "which code generator to use", + SpaceString (fn s => + explicitCodegen + := SOME (if s = "native" + then Native + else (case List.peek + (Control.Codegen.all, fn cg => + s = Control.Codegen.toString cg) of + SOME cg => Explicit cg + | NONE => usage (concat ["invalid -codegen flag: ", s]))))), + (Normal, "const", " ' '", "set compile-time constant", + SpaceString (fn s => + case String.tokens (s, Char.isSpace) of + [name, value] => + Compile.setCommandLineConstant {name = name, + value = value} + | _ => usage (concat ["invalid -const flag: ", s]))), + (Expert, "contify-into-main", " {false|true}", + "contify functions into main", + boolRef contifyIntoMain), + (Expert, "debug", " {false|true}", "produce executable with debug info", + Bool (fn b => (debug := b + ; debugRuntime := b))), + (Expert, "debug-runtime", " {false|true}", "produce executable with debug info", + boolRef debugRuntime), + (Expert, "debug-format", " {default|dwarf|dwarf+|drwaf2|stabs|stabs+}", + "choose debug symbol format", + SpaceString (fn s => + debugFormat := + (case s of + "default" => NONE + | "dwarf" => SOME Dwarf + | "dwarf+" => SOME DwarfPlus + | "dwarf2" => SOME Dwarf2 + | "stabs" => SOME Stabs + | "stabs+" => SOME StabsPlus + | _ => usage (concat ["invalid -debug-format flag: ", s])))), + let + val flag = "default-ann" + in + (Normal, flag, " ", "set annotation default for mlb files", + SpaceString + (fn s => reportAnnotation (s, flag, + Control.Elaborate.processDefault s))) + end, + (Normal, "default-type", " ''", "set default type", + SpaceString + (fn s => (case s of + "char8" => Control.defaultChar := s + | "int8" => Control.defaultInt := s + | "int16" => Control.defaultInt := s + | "int32" => Control.defaultInt := s + | "int64" => Control.defaultInt := s + | "intinf" => Control.defaultInt := s + | "real32" => Control.defaultReal := s + | "real64" => Control.defaultReal := s + | "widechar16" => Control.defaultWideChar := s + | "widechar32" => Control.defaultWideChar := s + | "word8" => Control.defaultWord := s + | "word16" => Control.defaultWord := s + | "word32" => Control.defaultWord := s + | "word64" => Control.defaultWord := s + | _ => usage (concat ["invalid -default-type flag: ", s])))), + (Expert, "diag-pass", " ", "keep diagnostic info for pass", + SpaceString + (fn s => + (case Regexp.fromString s of + SOME (re,_) => let val re = Regexp.compileDFA re + in List.push (diagPasses, re) + end + | NONE => usage (concat ["invalid -diag-pass flag: ", s])))), + let + val flag = "disable-ann" + in + (Normal, flag, " ", "disable annotation in mlb files", + SpaceString + (fn s => + reportAnnotation (s, flag, + Control.Elaborate.processEnabled (s, false)))) + end, + (Expert, "drop-pass", " ", "omit optimization pass", + SpaceString + (fn s => (case Regexp.fromString s of + SOME (re,_) => let val re = Regexp.compileDFA re + in List.push (dropPasses, re) + end + | NONE => usage (concat ["invalid -drop-pass flag: ", s])))), + let + val flag = "enable-ann" + in + (Expert, flag, " ", "globally enable annotation", + SpaceString + (fn s => + reportAnnotation (s, flag, + Control.Elaborate.processEnabled (s, true)))) + end, + (Expert, "error-threshhold", " ", "error threshhold (20)", + intRef errorThreshhold), + (Expert, "emit-main", " {true|false}", "emit main() startup function", + boolRef emitMain), + (Expert, "expert", " {false|true}", "enable expert status", + boolRef expert), + (Normal, "export-header", " ", "write C header file for _export's", + SpaceString (fn s => exportHeader := SOME s)), + (Expert, "format", + concat [" {", + String.concatWith + (List.keepAllMap + (Control.Format.all, fn cg => SOME (Control.Format.toString cg)), + "|"), + "}"], + "generated output format", + SpaceString (fn s => + Control.format + := (case List.peek + (Control.Format.all, fn cg => + s = Control.Format.toString cg) of + SOME cg => cg + | NONE => usage (concat ["invalid -format flag: ", s])))), + (Expert, "gc-check", " {limit|first|every}", "force GCs", + SpaceString (fn s => + gcCheck := + (case s of + "limit" => Limit + | "first" => First + | "every" => Every + | _ => usage (concat ["invalid -gc-check flag: ", s])))), + (Normal, "ieee-fp", " {false|true}", "use strict IEEE floating-point", + boolRef Native.IEEEFP), + (Expert, "indentation", " ", "indentation level in ILs", + intRef indentation), + (Normal, "inline", " ", "set inlining threshold", + Int (fn i => inlineNonRec := {small = i, + product = #product (!inlineNonRec)})), + (Expert, "inline-into-main", " {true|false}", + "inline functions into main", + boolRef inlineIntoMain), + (Expert, "inline-leafa-loops", " {true|false}", "leaf inline loops", + Bool (fn loops => + case !inlineLeafA of + {repeat, size, ...} => + inlineLeafA := + {loops = loops, repeat = repeat, size = size})), + (Expert, "inline-leafa-repeat", " {true|false}", "leaf inline repeat", + Bool (fn repeat => + case !inlineLeafA of + {loops, size, ...} => + inlineLeafA := + {loops = loops, repeat = repeat, size = size})), + (Expert, "inline-leafa-size", " ", "set leaf inlining threshold (20)", + SpaceString (fn s => + case !inlineLeafA of + {loops, repeat, ...} => + inlineLeafA := + {loops = loops, repeat = repeat, + size = (if s = "inf" + then NONE + else if String.forall (s, Char.isDigit) + then Int.fromString s + else (usage o concat) + ["invalid -inline-leaf-size flag: ", s])})), + (Expert, "inline-leafb-loops", " {true|false}", "leaf inline loops", + Bool (fn loops => + case !inlineLeafB of + {repeat, size, ...} => + inlineLeafB := + {loops = loops, repeat = repeat, size = size})), + (Expert, "inline-leafb-repeat", " {true|false}", "leaf inline repeat", + Bool (fn repeat => + case !inlineLeafB of + {loops, size, ...} => + inlineLeafB := + {loops = loops, repeat = repeat, size = size})), + (Expert, "inline-leafb-size", " ", "set leaf inlining threshold (40)", + SpaceString (fn s => + case !inlineLeafB of + {loops, repeat, ...} => + inlineLeafB := + {loops = loops, repeat = repeat, + size = (if s = "inf" + then NONE + else if String.forall (s, Char.isDigit) + then Int.fromString s + else (usage o concat) + ["invalid -inline-leaf-size flag: ", s])})), + (Expert, "inline-nonrec-product", " ", "set inlining threshold (320)", + Int (fn product => + case !inlineNonRec of + {small, ...} => + inlineNonRec := {small = small, product = product})), + (Expert, "inline-nonrec-small", " ", "set inlining threshold (60)", + Int (fn small => + case !inlineNonRec of + {product, ...} => + inlineNonRec := {small = small, product = product})), + (Normal, "keep", " {g|o}", "save intermediate files", + SpaceString (fn s => + case s of + "core-ml" => keepCoreML := true + | "dot" => keepDot := true + | "g" => keepGenerated := true + | "machine" => keepMachine := true + | "o" => keepO := true + | "rssa" => keepRSSA := true + | "ssa" => keepSSA := true + | "ssa2" => keepSSA2 := true + | "sxml" => keepSXML := true + | "xml" => keepXML := true + | _ => usage (concat ["invalid -keep flag: ", s]))), + (Expert, "keep-pass", " ", "keep the results of pass", + SpaceString + (fn s => (case Regexp.fromString s of + SOME (re,_) => let val re = Regexp.compileDFA re + in List.push (keepPasses, re) + end + | NONE => usage (concat ["invalid -keep-pass flag: ", s])))), + (Expert, "libname", " ", "the name of the generated library", + SpaceString (fn s => libname := s)), + (Normal, "link-opt", " ", "pass option to linker", + (SpaceString o tokenizeOpt) + (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "link-opt-quote", " ", "pass (quoted) option to linker", + SpaceString + (fn s => List.push (linkOpts, {opt = s, pred = OptPred.Yes}))), + (Expert, "loop-passes", " ", "loop optimization passes (1)", + Int + (fn i => + if i >= 1 + then loopPasses := i + else usage (concat ["invalid -loop-passes arg: ", Int.toString i]))), + (Expert, "mark-cards", " {true|false}", "mutator marks cards", + boolRef markCards), + (Expert, "max-function-size", " ", "max function size (blocks)", + intRef maxFunctionSize), + (Normal, "mlb-path-map", " ", "additional MLB path map", + SpaceString (fn s => mlbPathVars := !mlbPathVars @ readMlbPathMap s)), + (Normal, "mlb-path-var", " ' '", "additional MLB path var", + SpaceString + (fn s => mlbPathVars := !mlbPathVars @ + [case parseMlbPathVar s of + NONE => Error.bug ("strange mlb path var: " ^ s) + | SOME v => v])), + (Expert, "native-commented", " ", "level of comments (0)", + intRef Native.commented), + (Expert, "native-copy-prop", " {true|false}", + "use copy propagation", + boolRef Native.copyProp), + (Expert, "native-cutoff", " ", + "live transfer cutoff distance", + intRef Native.cutoff), + (Expert, "native-live-transfer", " {0,...,8}", + "use live transfer", + intRef Native.liveTransfer), + (Expert, "native-live-stack", " {false|true}", + "track liveness of stack slots", + boolRef Native.liveStack), + (Expert, "native-move-hoist", " {true|false}", + "use move hoisting", + boolRef Native.moveHoist), + (Expert, "native-optimize", " ", "level of optimizations", + intRef Native.optimize), + (Expert, "native-split", " ", "split assembly files at ~n lines", + Int (fn i => Native.split := SOME i)), + (Expert, "native-shuffle", " {true|false}", + "shuffle registers at C-calls", + Bool (fn b => Native.shuffle := b)), + (Expert, "opt-passes", " {default|minimal}", "level of optimizations", + SpaceString (fn s => + let + fun err s = + usage (concat ["invalid -opt-passes flag: ", s]) + in + List.foreach + (!optimizationPasses, fn {il,set,...} => + case set s of + Result.Yes () => () + | Result.No s' => err (concat [s', "(for ", il, ")"])) + end)), + (Normal, "output", " ", "name of output file", + SpaceString (fn s => output := SOME s)), + (Expert, "polyvariance", " {true|false}", "use polyvariance", + Bool (fn b => if b then () else polyvariance := NONE)), + (Expert, "polyvariance-hofo", " {true|false}", "duplicate higher-order fns only", + Bool (fn hofo => + case !polyvariance of + SOME {product, rounds, small, ...} => + polyvariance := SOME {hofo = hofo, + product = product, + rounds = rounds, + small = small} + | _ => ())), + (Expert, "polyvariance-product", " ", "set polyvariance threshold (300)", + Int (fn product => + case !polyvariance of + SOME {hofo, rounds, small, ...} => + polyvariance := SOME {hofo = hofo, + product = product, + rounds = rounds, + small = small} + | _ => ())), + (Expert, "polyvariance-rounds", " ", "set polyvariance rounds (2)", + Int (fn rounds => + case !polyvariance of + SOME {hofo, product, small, ...} => + polyvariance := SOME {hofo = hofo, + product = product, + rounds = rounds, + small = small} + | _ => ())), + (Expert, "polyvariance-small", " ", "set polyvariance threshold (30)", + Int (fn small => + case !polyvariance of + SOME {hofo, product, rounds, ...} => + polyvariance := SOME {hofo = hofo, + product = product, + rounds = rounds, + small = small} + | _ => ())), + (Expert, "prefer-abs-paths", " {false|true}", + "prefer absolute paths when referring to files", + boolRef preferAbsPaths), + (Expert, "prof-pass", " ", "keep profile info for pass", + SpaceString (fn s => + (case Regexp.fromString s of + SOME (re,_) => let val re = Regexp.compileDFA re + in + List.push (profPasses, re) + end + | NONE => usage (concat ["invalid -diag-pass flag: ", s])))), + (Normal, "profile", " {no|alloc|count|time}", + "produce executable suitable for profiling", + SpaceString + (fn s => + if !profileSet + then usage "can't have multiple -profile switches" + else + (profileSet := true + ; profile := (case s of + "no" => ProfileNone + | "alloc" => ProfileAlloc + | "call" => ProfileCallStack + | "count" => ProfileCount + | "drop" => ProfileDrop + | "label" => ProfileLabel + | "time" => (profileTimeSet := true + ; ProfileTimeLabel) + | "time-field" => ProfileTimeField + | "time-label" => ProfileTimeLabel + | _ => usage (concat + ["invalid -profile arg: ", s]))))), + (Normal, "profile-branch", " {false|true}", + "profile branches in addition to functions", + boolRef profileBranch), + (Expert, "profile-c", " ", + "include C-calls in files matching in profile", + SpaceString + (fn s => + (case Regexp.fromString s of + SOME (re,_) => let + open Regexp + val re = seq [anys, re, anys] + val re = compileDFA re + in List.push (profileC, re) + end + | NONE => usage (concat ["invalid -profile-c flag: ", s])))), + (Expert, "profile-exclude", " ", + "exclude files matching from profile", + SpaceString + (fn s => + (case Regexp.fromString s of + SOME (re,_) => let + open Regexp + val re = seq [anys, re, anys] + val re = compileDFA re + in List.push (profileInclExcl, (re, false)) + end + | NONE => usage (concat ["invalid -profile-exclude flag: ", s])))), + (Expert, "profile-il", " {source}", "where to insert profile exps", + SpaceString + (fn s => + case s of + "source" => profileIL := ProfileSource + | "ssa" => profileIL := ProfileSSA + | "ssa2" => profileIL := ProfileSSA2 + | _ => usage (concat ["invalid -profile-il arg: ", s]))), + (Expert, "profile-include", " ", + "include files matching from profile", + SpaceString + (fn s => + (case Regexp.fromString s of + SOME (re,_) => let + open Regexp + val re = seq [anys, re, anys] + val re = compileDFA re + in List.push (profileInclExcl, (re, true)) + end + | NONE => usage (concat ["invalid -profile-include flag: ", s])))), + (Expert, "profile-raise", " {false|true}", + "profile raises in addition to functions", + boolRef profileRaise), + (Normal, "profile-stack", " {false|true}", "profile the stack", + boolRef profileStack), + (Normal, "profile-val", " {false|true}", + "profile val bindings in addition to functions", + boolRef profileVal), + (Normal, "runtime", " ", "pass arg to runtime via @MLton", + SpaceString (fn s => List.push (runtimeArgs, s))), + (Expert, "show", " {anns|path-map}", "print specified data and stop", + SpaceString + (fn s => + show := SOME (case s of + "anns" => Show.Anns + | "path-map" => Show.PathMap + | _ => usage (concat ["invalid -show arg: ", s])))), + (Normal, "show-basis", " ", "write out the final basis environment", + SpaceString (fn s => showBasis := SOME s)), + (Normal, "show-def-use", " ", "write def-use information", + SpaceString (fn s => showDefUse := SOME s)), + (Expert, "show-types", " {true|false}", "show types in ILs", + boolRef showTypes), + (Expert, "ssa-passes", " ", "ssa optimization passes", + SpaceString + (fn s => + case List.peek (!Control.optimizationPasses, + fn {il, ...} => String.equals ("ssa", il)) of + SOME {set, ...} => + (case set s of + Result.Yes () => () + | Result.No s' => usage (concat ["invalid -ssa-passes arg: ", s'])) + | NONE => Error.bug "ssa optimization passes missing")), + (Expert, "ssa2-passes", " ", "ssa2 optimization passes", + SpaceString + (fn s => + case List.peek (!Control.optimizationPasses, + fn {il, ...} => String.equals ("ssa2", il)) of + SOME {set, ...} => + (case set s of + Result.Yes () => () + | Result.No s' => usage (concat ["invalid -ssa2-passes arg: ", s'])) + | NONE => Error.bug "ssa2 optimization passes missing")), + (Normal, "stop", " {f|g|o|tc}", "when to stop", + SpaceString + (fn s => + stop := (case s of + "f" => Place.Files + | "g" => Place.Generated + | "o" => Place.O + | "tc" => Place.TypeCheck + | _ => usage (concat ["invalid -stop arg: ", s])))), + (Expert, "sxml-passes", " ", "sxml optimization passes", + SpaceString + (fn s => + case List.peek (!Control.optimizationPasses, + fn {il, ...} => String.equals ("sxml", il)) of + SOME {set, ...} => + (case set s of + Result.Yes () => () + | Result.No s' => usage (concat ["invalid -sxml-passes arg: ", s'])) + | NONE => Error.bug "sxml optimization passes missing")), + (Normal, "target", + concat [" {", + (case targetMap () of + [] => "" + | [x] => #target x + | x :: _ => concat [#target x, "|..."]), + "}"], + "platform that executable will run on", + SpaceString + (fn t => + (target := (if t = "self" then Self else Cross t); + setTargetType (t, usage)))), + (Normal, "target-as-opt", " ", "target-dependent assembler option", + (SpaceString2 o tokenizeTargetOpt) + (fn (target, opt) => + List.push (asOpts, {opt = opt, pred = OptPred.Target target}))), + (Expert, "target-as-opt-quote", " ", "target-dependent assembler option (quoted)", + (SpaceString2 + (fn (target, opt) => + List.push (asOpts, {opt = opt, pred = OptPred.Target target})))), + (Normal, "target-cc-opt", " ", "target-dependent C compiler option", + (SpaceString2 o tokenizeTargetOpt) + (fn (target, opt) => + List.push (ccOpts, {opt = opt, pred = OptPred.Target target}))), + (Expert, "target-cc-opt-quote", " ", "target-dependent C compiler option (quoted)", + (SpaceString2 + (fn (target, opt) => + List.push (ccOpts, {opt = opt, pred = OptPred.Target target})))), + (Normal, "target-link-opt", " ", "target-dependent linker option", + (SpaceString2 o tokenizeTargetOpt) + (fn (target, opt) => + List.push (linkOpts, {opt = opt, pred = OptPred.Target target}))), + (Expert, "target-link-opt-quote", " ", "target-dependent linker option (quoted)", + (SpaceString2 + (fn (target, opt) => + List.push (linkOpts, {opt = opt, pred = OptPred.Target target})))), + (Expert, #1 trace, " name1,...", "trace compiler internals", #2 trace), + (Expert, "type-check", " {false|true}", "type check ILs", + boolRef typeCheck), + (Normal, "verbose", " {0|1|2|3}", "how verbose to be", + SpaceString + (fn s => + verbosity := (case s of + "0" => Silent + | "1" => Top + | "2" => Pass + | "3" => Detail + | _ => usage (concat ["invalid -verbose arg: ", s])))), + (Expert, "warn-ann", " {true|false}", + "unrecognized annotation warnings", + boolRef warnAnn), + (Expert, "warn-deprecated", " {true|false}", + "deprecated feature warnings", + boolRef warnDeprecated), + (Expert, "xml-passes", " ", "xml optimization passes", + SpaceString + (fn s => + case List.peek (!Control.optimizationPasses, + fn {il, ...} => String.equals ("xml", il)) of + SOME {set, ...} => + (case set s of + Result.Yes () => () + | Result.No s' => usage (concat ["invalid -xml-passes arg: ", s'])) + | NONE => Error.bug "xml optimization passes missing")), + (Expert, "zone-cut-depth", " ", "zone cut depth", + intRef zoneCutDepth) + ], + fn (style, name, arg, desc, opt) => + {arg = arg, desc = desc, name = name, opt = opt, style = style}) + end + +val mainUsage = + "mlton [option ...] file.{c|mlb|o|sml} [file.{c|o|s|S} ...]" + +val {parse, usage} = + Popt.makeUsage {mainUsage = mainUsage, + makeOptions = makeOptions, + showExpert = fn () => !expert} + +val usage = fn s => (usage s; raise Fail "unreachable") + +fun commandLine (args: string list): unit = + let + open Control + datatype z = datatype MLton.Platform.Arch.t + datatype z = datatype MLton.Platform.OS.t + val args = + case args of + lib :: args => + (libDir := OS.Path.mkCanonical lib + ; args) + | _ => Error.bug "incorrect args from shell script" + val () = setTargetType ("self", usage) + val result = parse args + + val target = !target + val targetStr = + case target of + Cross s => s + | Self => "self" + val targetsDir = + OS.Path.mkAbsolute { path = "targets", + relativeTo = !libDir } + val targetDir = + OS.Path.mkAbsolute { path = targetStr, + relativeTo = targetsDir } + val () = libTargetDir := targetDir + val targetArch = !Target.arch + val archStr = String.toLower (MLton.Platform.Arch.toString targetArch) + val targetOS = !Target.os + val OSStr = String.toLower (MLton.Platform.OS.toString targetOS) + + (* Determine whether code should be PIC (position independent) or not. + * This decision depends on the platform and output format. + *) + val positionIndependent = + case (targetOS, targetArch, !format) of + (* Windows is never position independent *) + (MinGW, _, _) => false + | (Cygwin, _, _) => false + (* Technically, Darwin should always be PIC. + * However, PIC on i386/darwin is unimplemented so we avoid it. + * PowerPC PIC is bad too, but the C codegen will use PIC behind + * our back unless forced, so let's just admit that it's PIC. + *) + | (Darwin, X86, Executable) => false + | (Darwin, X86, Archive) => false + | (Darwin, _, _) => true + (* On ELF systems, we only need PIC for LibArchive/Library *) + | (_, _, Library) => true + | (_, _, LibArchive) => true + | _ => false + val () = Control.positionIndependent := positionIndependent + + val stop = !stop + + val () = + align := (case !explicitAlign of + NONE => if defaultAlignIs8 () then Align8 else Align4 + | SOME a => a) + val () = + codegen := (case !explicitCodegen of + NONE => + if hasCodegen (x86Codegen) + then x86Codegen + else if hasCodegen (amd64Codegen) + then amd64Codegen + else CCodegen + | SOME Native => + if hasCodegen (x86Codegen) + then x86Codegen + else if hasCodegen (amd64Codegen) + then amd64Codegen + else usage (concat ["can't use native codegen on ", + MLton.Platform.Arch.toString targetArch, + " target"]) + | SOME (Explicit cg) => cg) + val () = MLton.Rusage.measureGC (!verbosity <> Silent) + val () = if !profileTimeSet + then (case !codegen of + x86Codegen => profile := ProfileTimeLabel + | amd64Codegen => profile := ProfileTimeLabel + | _ => profile := ProfileTimeField) + else () + val () = if !exnHistory + then (case !profile of + ProfileNone => profile := ProfileCallStack + | ProfileCallStack => () + | _ => usage "can't use -profile with Exn.keepHistory" + ; profileRaise := true) + else () + + val () = + Compile.setCommandLineConstant + {name = "CallStack.keep", + value = Bool.toString (!Control.profile = Control.ProfileCallStack)} + + val () = + let + val sizeMap = + List.map + (File.lines (OS.Path.joinDirFile {dir = !Control.libTargetDir, + file = "sizes"}), + fn line => + case String.tokens (line, Char.isSpace) of + [ty, "=", size] => + (case Int.fromString size of + NONE => Error.bug (concat ["strange size: ", size]) + | SOME size => + (ty, Bytes.toBits (Bytes.fromInt size))) + | _ => Error.bug (concat ["strange size mapping: ", line])) + fun lookup ty' = + case List.peek (sizeMap, fn (ty, _) => String.equals (ty, ty')) of + NONE => Error.bug (concat ["missing size mapping: ", ty']) + | SOME (_, size) => size + in + Control.Target.setSizes + {cint = lookup "cint", + cpointer = lookup "cpointer", + cptrdiff = lookup "cptrdiff", + csize = lookup "csize", + header = lookup "header", + mplimb = lookup "mplimb", + objptr = lookup "objptr", + seqIndex = lookup "seqIndex"} + end + + fun tokenize l = + String.tokens (concat (List.separate (l, " ")), Char.isSpace) + + (* When cross-compiling, use the named cross compiler. + * Older gcc versions used -b for multiple targets. + * If this is still needed, a shell script wrapper can hide this. + *) + val gcc = + case target of + Cross s => + let + val {dir = gccDir, file = gccFile} = + OS.Path.splitDirFile (!gcc) + in + OS.Path.joinDirFile + {dir = gccDir, + file = s ^ "-" ^ gccFile} + end + | Self => !gcc + val arScript = !arScript + + fun addTargetOpts opts = + List.fold + (!opts, [], fn ({opt, pred}, ac) => + if (case pred of + OptPred.Target s => + let + val s = String.toLower s + in + s = archStr orelse s = OSStr + end + | OptPred.Yes => true) + then opt :: ac + else ac) + val asOpts = addTargetOpts asOpts + val ccOpts = addTargetOpts ccOpts + val ccOpts = concat ["-I", + OS.Path.mkAbsolute { path = "include", + relativeTo = !libTargetDir }] + :: ccOpts + val linkOpts = + List.concat [[concat ["-L", !libTargetDir]], + if !debugRuntime then + ["-lmlton-gdb", "-lgdtoa-gdb"] + else if positionIndependent then + ["-lmlton-pic", "-lgdtoa-pic"] + else + ["-lmlton", "-lgdtoa"], + addTargetOpts linkOpts] + val linkArchives = + if !debugRuntime then + [OS.Path.joinDirFile { dir = !libTargetDir, file = "libmlton-gdb.a" }, + OS.Path.joinDirFile { dir = !libTargetDir, file = "libgdtoa-gdb.a" }] + else if positionIndependent then + [OS.Path.joinDirFile { dir = !libTargetDir, file = "libmlton-pic.a" }, + OS.Path.joinDirFile { dir = !libTargetDir, file = "libgdtoa-pic.a" }] + else + [OS.Path.joinDirFile { dir = !libTargetDir, file = "libmlton.a" }, + OS.Path.joinDirFile { dir = !libTargetDir, file = "libgdtoa.a" }] + val _ = + if not (hasCodegen (!codegen)) + then usage (concat ["can't use ", + Control.Codegen.toString (!codegen), + " codegen on ", + MLton.Platform.Arch.toString targetArch, + " target"]) + else () + val () = + Control.labelsHaveExtra_ := (case targetOS of + Cygwin => true + | Darwin => true + | MinGW => true + | _ => false) + val _ = + chunk := + (case !explicitChunk of + NONE => (case !codegen of + amd64Codegen => ChunkPerFunc + | CCodegen => Coalesce {limit = 4096} + | x86Codegen => ChunkPerFunc + ) + | SOME c => c) + val _ = if not (!Control.codegen = x86Codegen) andalso !Native.IEEEFP + then usage "must use x86 codegen with -ieee-fp true" + else () + val _ = + if !keepDot andalso List.isEmpty (!keepPasses) + then keepSSA := true + else () + val () = + keepDefUse + := (isSome (!showDefUse) + orelse (Control.Elaborate.enabled Control.Elaborate.warnUnused) + orelse (Control.Elaborate.default Control.Elaborate.warnUnused)) + val warnMatch = + (Control.Elaborate.enabled Control.Elaborate.nonexhaustiveMatch) + orelse (Control.Elaborate.enabled Control.Elaborate.redundantMatch) + orelse (Control.Elaborate.default Control.Elaborate.nonexhaustiveMatch <> + Control.Elaborate.DiagEIW.Ignore) + orelse (Control.Elaborate.default Control.Elaborate.redundantMatch <> + Control.Elaborate.DiagEIW.Ignore) + val _ = elaborateOnly := (stop = Place.TypeCheck + andalso not (warnMatch) + andalso not (!keepDefUse)) + val _ = + case targetOS of + Darwin => () + | FreeBSD => () + | HPUX => () + | Linux => () + | MinGW => () + | NetBSD => () + | OpenBSD => () + | Solaris => () + | _ => + if !profile = ProfileTimeField + orelse !profile = ProfileTimeLabel + then usage (concat ["can't use -profile time on ", + MLton.Platform.OS.toString targetOS]) + else () + fun printVersion (out: Out.t): unit = + Out.output (out, concat [Version.banner, "\n"]) + val () = + case !show of + NONE => () + | SOME info => + (case info of + Show.Anns => + Layout.outputl (Control.Elaborate.document {expert = !expert}, + Out.standard) + | Show.PathMap => + let + open Layout + in + outputl (align + (List.map (Control.mlbPathMap (), + fn {var, path, ...} => + str (concat [var, " ", path]))), + Out.standard) + end + ; let open OS.Process in exit success end) + in + case result of + Result.No msg => usage msg + | Result.Yes [] => + (inputFile := "" + ; if isSome (!showBasis) + then (trace (Top, "Type Check SML") + Compile.elaborateSML {input = []}) + else if !buildConstants + then Compile.outputBasisConstants Out.standard + else if !verbosity = Silent orelse !verbosity = Top + then printVersion Out.standard + else outputHeader' (No, Out.standard)) + | Result.Yes (input :: rest) => + let + val _ = inputFile := File.base (File.fileOf input) + val (start, base) = + let + val rec loop = + fn [] => usage (concat ["invalid file suffix on ", input]) + | (suf, start, hasNum) :: sufs => + if String.hasSuffix (input, {suffix = suf}) + then (start, + let + val f = File.base input + in + if hasNum + then File.base f + else f + end) + else loop sufs + datatype z = datatype Place.t + in + loop [(".mlb", MLB, false), + (".sml", SML, false), + (".c", Generated, true), + (".o", O, true)] + end + val _ = + List.foreach + (rest, fn f => + if List.exists ([".c", ".o", ".s", ".S"], fn suffix => + String.hasSuffix (f, {suffix = suffix})) + then File.withIn (f, fn _ => ()) + else usage (concat ["invalid file suffix: ", f])) + val csoFiles = rest + in + case Place.compare (start, stop) of + GREATER => usage (concat ["cannot go from ", Place.toString start, + " to ", Place.toString stop]) + | EQUAL => usage "nothing to do" + | LESS => + let + val _ = + if !verbosity = Top + then printVersion Out.error + else () + val tempFiles: File.t list ref = ref [] + val tmpDir = + let + val (tmpVar, default) = + case MLton.Platform.OS.host of + MinGW => ("TEMP", "C:/WINDOWS/TEMP") + | _ => ("TMPDIR", "/tmp") + in + case Process.getEnv tmpVar of + NONE => default + | SOME d => d + end + fun temp (suf: string): File.t = + let + val (f, out) = + File.temp {prefix = OS.Path.concat (tmpDir, "file"), + suffix = suf} + val _ = Out.close out + val _ = List.push (tempFiles, f) + in + f + end + fun suffix s = concat [base, s] + fun maybeOut suf = + case !output of + NONE => suffix suf + | SOME f => f + fun maybeOutBase suf = + case !output of + NONE => suffix suf + | SOME f => if File.extension f = SOME "exe" + then concat [File.base f, suf] + else concat [f, suf] + val { base = outputBase, ext=_ } = + OS.Path.splitBaseExt (maybeOut ".ext") + val { file = defLibname, dir=_ } = + OS.Path.splitDirFile outputBase + val defLibname = + if String.hasPrefix (defLibname, {prefix = "lib"}) + then String.extract (defLibname, 3, NONE) + else defLibname + fun toAlNum c = if Char.isAlphaNum c then c else #"_" + val () = + if !libname <> "" then () else + libname := CharVector.map toAlNum defLibname + (* Library output includes a header by default *) + val () = + case (!format, !exportHeader) of + (Executable, _) => () + | (_, NONE) => exportHeader := SOME (!libname ^ ".h") + | _ => () + val _ = + atMLtons := + Vector.fromList + (maybeOut "" :: tokenize (rev ("--" :: (!runtimeArgs)))) + (* The -Wa,--gstabs says to pass the --gstabs option to the + * assembler. This tells the assembler to generate stabs + * debugging information for each assembler line. + *) + val (gccDebug, asDebug) = + case !debugFormat of + NONE => (["-g"], "-Wa,-g") + | SOME Dwarf => (["-gdwarf", "-g2"], "-Wa,--gdwarf2") + | SOME DwarfPlus => (["-gdwarf+", "-g2"], "-Wa,--gdwarf2") + | SOME Dwarf2 => (["-gdwarf-2", "-g2"], "-Wa,--gdwarf2") + | SOME Stabs => (["-gstabs", "-g2"], "-Wa,--gstabs") + | SOME StabsPlus => (["-gstabs+", "-g2"], "-Wa,--gstabs") + fun compileO (inputs: File.t list): unit = + let + val output = + case (!format, targetOS) of + (Archive, _) => maybeOut ".a" + | (Executable, _) => maybeOut "" + | (LibArchive, _) => maybeOut ".a" + | (Library, Darwin) => maybeOut ".dylib" + | (Library, Cygwin) => !libname ^ ".dll" + | (Library, MinGW) => !libname ^ ".dll" + | (Library, _) => maybeOut ".so" + val libOpts = + case targetOS of + Darwin => [ "-dynamiclib" ] + | Cygwin => [ "-shared", + "-Wl,--out-implib," ^ + maybeOut ".a", + "-Wl,--output-def," ^ + !libname ^ ".def"] + | MinGW => [ "-shared", + "-Wl,--out-implib," ^ + maybeOut ".a", + "-Wl,--output-def," ^ + !libname ^ ".def"] + | _ => [ "-shared" ] + val _ = + trace (Top, "Link") + (fn () => + if !format = Archive orelse + !format = LibArchive + then System.system + (arScript, + List.concat + [[targetStr, OSStr, output], + inputs, + linkArchives]) + else System.system + (gcc, + List.concat + [["-o", output], + if !format = Library then libOpts else [], + if !debug then gccDebug else [], + inputs, + linkOpts])) + () + (* gcc on Cygwin appends .exe, which I don't want, so + * move the output file to it's rightful place. + * Notice that we do not use targetOS here, since we + * care about the platform we're running on, not the + * platform we're generating for. + * + * We want to keep the .exe as is for MinGW/Win32. + *) + val _ = + if MLton.Platform.OS.host = Cygwin + then + if String.contains (output, #".") + then () + else + File.move {from = concat [output, ".exe"], + to = output} + else () + in + () + end + fun mkOutputO (c: Counter.t, input: File.t): File.t = + if stop = Place.O orelse !keepO + then + if File.dirOf input = File.dirOf (maybeOutBase ".o") + then + concat [File.base input, ".o"] + else + maybeOutBase + (concat [".", + Int.toString (Counter.next c), + ".o"]) + else temp ".o" + fun compileC (c: Counter.t, input: File.t): File.t = + let + val debugSwitches = gccDebug @ ["-DASSERT=1"] + val output = mkOutputO (c, input) + + val _ = + System.system + (gcc, + List.concat + [[ "-std=gnu99", "-c" ], + if !format = Executable + then [] else [ "-DLIBNAME=" ^ !libname ], + if positionIndependent + then [ "-fPIC", "-DPIC" ] else [], + if !debug then debugSwitches else [], + ccOpts, + ["-o", output], + [input]]) + in + output + end + fun compileS (c: Counter.t, input: File.t): File.t = + let + val output = mkOutputO (c, input) + val _ = + System.system + (gcc, + List.concat + [["-c"], + if !debug then [asDebug] else [], + asOpts, + ["-o", output], + [input]]) + in + output + end + fun compileCSO (inputs: File.t list): unit = + if List.forall (inputs, fn f => + SOME "o" = File.extension f) + then compileO inputs + else + let + val c = Counter.new 0 + val oFiles = + trace (Top, "Compile and Assemble") + (fn () => + List.fold + (inputs, [], fn (input, ac) => + let + val extension = File.extension input + in + if SOME "o" = extension + then input :: ac + else if SOME "c" = extension + then (compileC (c, input)) :: ac + else if SOME "s" = extension + orelse SOME "S" = extension + then (compileS (c, input)) :: ac + else Error.bug + (concat + ["invalid extension: ", + Option.toString (fn s => s) extension]) + end)) + () + in + case stop of + Place.O => () + | _ => compileO (rev oFiles) + end + fun mkCompileSrc {listFiles, elaborate, compile} input = + let + val outputs: File.t list ref = ref [] + val r = ref 0 + fun make (style: style, suf: string) () = + let + val suf = concat [".", Int.toString (!r), suf] + val _ = Int.inc r + val file = (if !keepGenerated + orelse stop = Place.Generated + then maybeOutBase + else temp) suf + val _ = List.push (outputs, file) + val out = Out.openOut file + fun print s = Out.output (out, s) + val _ = outputHeader' (style, out) + fun done () = Out.close out + in + {file = file, + print = print, + done = done} + end + val _ = + case !verbosity of + Silent => () + | Top => () + | _ => + outputHeader + (Control.No, fn l => + let val out = Out.error + in Layout.output (l, out) + ; Out.newline out + end) + val _ = + case stop of + Place.Files => + Vector.foreach + (listFiles {input = input}, fn f => + (print (String.translate + (f, fn #"\\" => "/" | c => str c)) + ; print "\n")) + | Place.TypeCheck => + trace (Top, "Type Check SML") + elaborate + {input = input} + | _ => + trace (Top, "Compile SML") + compile + {input = input, + outputC = make (Control.C, ".c"), + outputS = make (Control.Assembly, ".s")} + in + case stop of + Place.Files => () + | Place.TypeCheck => () + | Place.Generated => () + | _ => + (* Shrink the heap before calling gcc. *) + (MLton.GC.pack () + ; compileCSO (List.concat [!outputs, csoFiles])) + end + val compileSML = + mkCompileSrc {listFiles = fn {input} => Vector.fromList input, + elaborate = Compile.elaborateSML, + compile = Compile.compileSML} + val compileMLB = + mkCompileSrc {listFiles = Compile.sourceFilesMLB, + elaborate = Compile.elaborateMLB, + compile = Compile.compileMLB} + fun compile () = + case start of + Place.SML => compileSML [input] + | Place.MLB => compileMLB input + | Place.Generated => compileCSO (input :: csoFiles) + | Place.O => compileCSO (input :: csoFiles) + | _ => Error.bug "invalid start" + val doit + = trace (Top, "MLton") + (fn () => + Exn.finally + (compile, fn () => + List.foreach (!tempFiles, File.remove))) + in + doit () + end + end + end + +val commandLine = Process.makeCommandLine commandLine + +val main = fn (_, args) => commandLine args + +val mainWrapped = fn () => OS.Process.exit (commandLine (CommandLine.arguments ())) + +end