Mass commit in case my laptop bricks again...

Author: igstan

lib/core/lib.cm

@@ -0,0 +1,8 @@
+library (0.1.0)
+  signature LIST
+  structure List
+is
+  $/basis.cm
+
+  src/list.sig
+  src/list.sml

lib/core/src/list.sig

@@ -0,0 +1,8 @@
+signature LIST =
+  sig
+    include LIST
+
+    val countWhere : ('a -> bool) -> 'a list -> int
+
+    val foldl : 'a list -> { seed : 'b, step : 'a * 'b -> 'b } -> 'b
+  end

lib/core/src/list.sml

@@ -0,0 +1,31 @@
+structure List : LIST =
+  struct
+    open LIST
+
+    fun foldl list { seed, step } = List.foldl step seed list
+    fun foldr list { seed, step } = List.foldr step seed list
+
+    fun takeWhile _ [] = []
+      | takeWhile p (x :: xs) = if p x then x :: takeWhile p xs else []
+
+    fun takeUntil p = takeWhile (not o p)
+
+    fun countWhere predicate list =
+      raise Fail "not implemented"
+
+    fun bound xs ys a b =
+      case (xs, ys) of
+        (x, []) => a
+      | ([], y) => b
+      | (_ :: xs, _ :: ys) => recur xs ys a b
+
+    (**
+     * Returns the list with more elements.
+     *)
+    fun max a b = bound a b a b
+
+    (**
+     * Returns the list with fewer elements.
+     *)
+    fun min a b = bound a b b a
+  end

lib/core/src/other.sml

@@ -0,0 +1,11 @@
+signature FOLDABLE =
+  sig
+    type 'a t
+    type ('a, 'b) arrow = 'a -> 'b
+    type 'a monoid = {
+      zero : 'a,
+      plus : 'a * 'a -> 'a
+    }
+
+    val foldMap : 'm monoid -> ('a -> 'm) -> 'a t -> 'm
+  end

src/class-name.sml

@@ -4,6 +4,6 @@
 structure ClassName =
   struct
     type t = Text.t
-    fun fromParts parts = Text.concatWith "/" parts
+    fun fromParts parts = String.concatWith "/" parts
     fun fromString s = s
   end

src/compilable.sig

@@ -0,0 +1,33 @@
+(* Reader Monad *)
+signature CONFIGURABLE =
+  sig
+    type 'a t
+    type config
+
+    val from : (config -> 'a) -> 'a t
+
+    val get : key ->
+
+    val run : config -> 'a t -> 'a
+  end
+
+structure Configurable =
+  struct
+    type 'computation t = int
+
+    fun from f =
+      raise Fail "not implemented"
+
+    fun run config =
+  end
+
+Configurable.from (fn config =>
+
+)
+
+signature COMPILABLE =
+  sig
+    type t
+
+    val compile : ConstPool.t -> t -> (Word8Vector.vector, ConstPool.t) Configurable.t
+  end

src/index.sml

@@ -0,0 +1,4 @@
+structure Index =
+  struct
+    type t = int
+  end

src/indexed-instr.sml

@@ -0,0 +1,18 @@
+signature INDEXED_INSTR =
+  sig
+    type t
+
+    val index : t -> Index.t
+    val instr : t -> Instr.t
+  end
+
+
+structure IndexedInstr : INDEXED_INSTR =
+  struct
+    type t = (Index.t, Instr.t)
+
+    val fromPair = Fn.id
+
+    fun index (i, _) => i
+    fun instr (_, i) => i
+  end

src/main.sml

@@ -1,5 +1,7 @@
 structure Main =
   struct
+    open Fn.Syntax infix |>
+
     structure Instr = LabeledInstr
 
     fun symbol class name descriptor = {
@@ -272,9 +274,9 @@ structure Main =
       ]
     }
 
-    val class = Class.from {
+    fun class name = Class.from {
       accessFlags = [Class.Flag.PUBLIC],
-      thisClass = ClassName.fromString "Main",
+      thisClass = ClassName.fromString name,
       superClass = ClassName.fromString "java/lang/Object",
       interfaces = [],
       attributes = [Attr.SourceFile "main.sml"],
@@ -297,9 +299,9 @@ structure Main =
         string o dropl isSpace o dropr isSpace o full
       end
 
-    fun java classPath className =
+    fun java { classpath } className =
       let
-        val proc = Unix.execute ("/usr/bin/java", ["-cp", classPath, className])
+        val proc = Unix.execute ("/usr/bin/java", ["-cp", classpath, className])
         val output = TextIO.inputAll (Unix.textInstreamOf proc)
       in
         Unix.reap proc
@@ -308,27 +310,29 @@ structure Main =
 
     fun main () =
       let
+        val className = "Main"
         val workDir = OS.FileSys.getDir ()
-        val bytes = Class.compile class
-        val f = BinIO.openOut (OS.Path.joinDirFile { dir = workDir, file = "Main.class" })
-        val _ = BinIO.output (f, bytes)
-        val _ = BinIO.closeOut f
-        val output = java workDir "Main"
+        val binDir = OS.Path.joinDirFile { dir = workDir, file = "bin" }
+        val fileName = OS.Path.joinDirFile { dir = binDir, file = className ^ ".class" }
+        val classFile = BinIO.openOut fileName
+        val bytes = Class.compile (class className)
+        val _ = BinIO.output (classFile, bytes)
+        val _ = BinIO.closeOut classFile
+        val output = java { classpath = binDir } className
       in
         print (output ^ "\n")
       end
 
     fun stackMap () =
-      let
-        val { attributes = [Attr.Code { code, ... }], ... } = nestedLoops
-        val { offsetedInstrs, ... } = Instr.compileList ConstPool.empty code
-      in
-        StackLang.compileCompact
-        (
-          StackLang.interpret
-          (
-            Verifier.verify offsetedInstrs
-          )
-        )
-      end
+      case nestedLoops of
+      | { attributes = [Attr.Code { code, ... }], ... } =>
+        let
+          val { offsetedInstrs, ... } = Instr.compileList ConstPool.empty code
+        in
+          offsetedInstrs
+            |> Verifier.verify
+            |> StackLang.interpret
+            |> StackLang.compileCompact
+        end
+      | _ => raise Fail "not implemented"
   end

src/stack-map/stack-lang.sml

@@ -2,12 +2,17 @@ structure StackLang =
   struct
     type local_index = int
 
+    type indexed_type = {
+      index : local_index,
+      vtype : VerificationType.t
+    }
+
     datatype t =
     | Push of VerificationType.t
     | Pop of VerificationType.t
-    | Load of local_index * VerificationType.t
-    | Store of local_index * VerificationType.t
-    | Local of local_index * VerificationType.t
+    | Load of local_index * VerificationType.t (* indexed_type *)
+    | Store of local_index * VerificationType.t (* indexed_type *)
+    | Local of local_index * VerificationType.t (* indexed_type *)
     | Branch of { targetOffset : int, fallsThrough : bool }
 
     exception StackUnderflow
@@ -17,11 +22,15 @@ structure StackLang =
       case t of
       | Push vtype => "Push " ^ VerificationType.toString vtype
       | Pop vtype => "Pop " ^ VerificationType.toString vtype
-      | Load (index, vtype) => "Load ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
-      | Store (index, vtype) => "Store ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
-      | Local (index, vtype) => "Local ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
+      | Load (index, vtype) =>
+          "Load ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
+      | Store (index, vtype) =>
+          "Store ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
+      | Local (index, vtype) =>
+          "Local ("^ Int.toString index ^", "^ VerificationType.toString vtype ^")"
       | Branch { targetOffset, fallsThrough } =>
-          "Branch { targetOffset = "^ Int.toString targetOffset ^", fallsThrough = "^ Bool.toString fallsThrough ^" }"
+          "Branch { targetOffset = "^ Int.toString targetOffset
+          ^", fallsThrough = "^ Bool.toString fallsThrough ^" }"
 
     fun interpret instrs =
       let