Adding .fun extension to Standard ML definition and adding some sample files

lib/linguist/samples.json

@@ -395,6 +395,7 @@
       ".nut"
     ],
     "Standard ML": [
+      ".fun",
       ".sig",
       ".sml"
     ],
@@ -519,8 +520,8 @@
       ".gemrc"
     ]
   },
-  "tokens_total": 433258,
+  "tokens_total": 439420,
-  "languages_total": 510,
+  "languages_total": 512,
   "tokens": {
     "ABAP": {
       "*/**": 1,
@@ -43025,64 +43026,594 @@
       "signature": 2,
       "LAZY_BASE": 3,
       "sig": 2,
-      "type": 2,
+      "type": 5,
-      "a": 18,
+      "a": 74,
       "lazy": 12,
-      "-": 13,
+      "-": 19,
-      ")": 23,
+      ")": 826,
-      "end": 6,
+      "end": 52,
       "LAZY": 1,
-      "bool": 4,
+      "bool": 9,
-      "val": 12,
+      "val": 143,
       "inject": 3,
-      "toString": 2,
+      "toString": 3,
-      "(": 22,
+      "(": 822,
-      "string": 1,
+      "string": 14,
       "eq": 2,
-      "*": 1,
+      "*": 9,
       "eqBy": 3,
-      "compare": 2,
+      "compare": 7,
       "order": 2,
       "map": 2,
-      "b": 2,
+      "b": 58,
-      "structure": 6,
+      "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,
+      "fn": 124,
-      "raise": 1,
+      "raise": 5,
       "LazyMemoBase": 2,
-      "datatype": 1,
+      "datatype": 28,
-      "|": 1,
+      "|": 225,
       "Done": 1,
-      "of": 1,
+      "of": 90,
-      "unit": 1,
+      "unit": 6,
-      "let": 1,
+      "let": 43,
-      "open": 1,
+      "open": 8,
       "B": 1,
-      "x": 15,
+      "x": 59,
       "isUndefined": 2,
-      "ignore": 1,
+      "ignore": 2,
-      ";": 1,
+      ";": 20,
-      "false": 1,
+      "false": 31,
-      "handle": 1,
+      "handle": 3,
-      "true": 1,
+      "true": 35,
-      "if": 1,
+      "if": 50,
-      "then": 1,
+      "then": 50,
-      "else": 1,
+      "else": 50,
-      "p": 4,
+      "p": 6,
-      "y": 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"
 }

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 *)