Made changes before push to github

README.md

@@ -0,0 +1,23 @@
+NanoML is a simple eager functional programming language based on [MiniML](http://www.andrej.com/plzoo/html/miniml.html) from [The Programming Language Zoo](http://www.andrej.com/plzoo/)
+
+NanoML written on [_F#_](http://en.wikipedia.org/wiki/F_Sharp_%28programming_language%29). Lexing and parsing done by fslex and fsyacc. Runtime is a simple [SECD virtual machine](http://en.wikipedia.org/wiki/SECD_machine).
+
+NanoML has 4 types _int_, _float_, _bool_, (* -> *). Language hasn't type inference at all. But type checker statically check all types in program. 
+
+Language support functions, values, recursion, closures.
+
+Also language provides with simple interpreter shell.
+
+Below is a classical example recursive factorial function:
+
+	let fact = 
+		fun f (n : int) : int =>
+			if n = 0 then 1
+			else n * f (n - 1)
+		end;;
+
+
+
+To see more NanoML code check _stdlib.nanoml_ which contains small set of common and useful functions.
+
+To get full language syntax see _NanoMLParser.fsy_.

build/build-nanoml.cmd

@@ -1,4 +1,10 @@
 call compile-lexer.cmd
 call compile-parser.cmd
 
-fsc ../src/NanoML/List.fs ../src/NanoML/NanoMLAst.fs ../src/NanoML/TypeChecker.fs ../src/NanoML/NanoMLParser.fs ../src/NanoML/NanoMLLexer.fs ../src/NanoML/VM.fs ../src/NanoML/Compile.fs ../src/NanoML/NanoML.fs -r FSharp.Powerpack.dll
+set original_dir=%cd%
+
+cd ../src/NanoML
+
+fsc List.fs NanoMLAst.fs NanoMLTAst.fs TypeChecker.fs NanoMLParser.fs NanoMLLexer.fs VM.fs NanoMLLang.fs Compile.fs NanoML.fs -r ../../lib/FSharp.Powerpack.dll
+
+cd %original_dir%

src/NanoML.Stdlib/stdlib.nanoml

@@ -1,10 +1,12 @@
 let pi = 3.141592654;;
 let e = 2.718281828;;
 
+let not = fun _ (b : bool) : bool => if b then false else true end;;
+
 let fact = 
-	fun e (n : int) : int =>
-		if n = 1 then 1
-		else n * e (n - 1)
+	fun f (n : int) : int =>
+		if n = 0 then 1
+		else n * f (n - 1)
 	end;;
 
 let sqr =
@@ -82,6 +84,27 @@ let exp =
 			in
 		sum 1 1.0
 	end;;
+
+let incr =
+	fun _ (x : int) : int =>
+		x + 1
+	end;;
+
+(* generate Church number *)
+let funpow = 
+	fun funpow (n : int) : (int -> int) -> int -> int =>
+		fun _ (f : int -> int) : int -> int =>
+			fun _ (x : int) : int =>
+				if n = 0 then x
+				else funpow (n-1) f (f x)
+			end
+		end
+	end;;
+
+let defrock =
+	fun _ (n : (int -> int) -> int -> int) : int =>
+		n incr 0
+	end;;
 (*
 
 let test =

src/NanoML/Compile.fs

@@ -45,7 +45,7 @@ let rec emit = function
     | TDivide (e1, e2, ty) -> (emit e1) @ (emit e2) @ [div ty]
     | TEqual (e1, e2) -> (emit e1) @ (emit e2) @ [eq e1.Type]
     | TLess (e1, e2) -> (emit e1) @ (emit e2) @ [less e1.Type]
-    | TFun (f, x, _, _, e, _) -> [ILdClosure (f, x, emit e @ [IPopEnv])]
+    | TFun (f, arg, _, _, e, _) -> [ILdClosure (f, arg, emit e @ [IPopEnv])]
     | TCond (e1, e2, e3, _) -> (emit e1) @ [IBranch (emit e2, emit e3)]
     | TApply (e1, e2, _) -> (emit e1) @ (emit e2) @ [ICall]
     | astNode -> failwithf "Not valid node for emitter: %A" astNode

src/NanoML/NanoML.fs

@@ -10,41 +10,43 @@ open System.IO
 
 type context = (name * ty) list
 
-type env = (name * VirtualMachine.mvalue) list
-
-
 type settings = { DumpDeclarations : bool
                   DumpVMCode : bool
-                  DumpTAst : bool }
+                  DumpTAst : bool
+                  DumpContext : bool
+                  DumpEnv : bool }
 
 let inline dumpVmCode (s : settings) (frm : VirtualMachine.frame) =
     if s.DumpVMCode then
         printfn "\ndump VM code:"
         printfn "%s" (VirtualMachine.frame2string frm)
     frm
 
-let inline dumpTAst (s : settings) (texpr : texpr) = 
+let inline dumpTAst (s : settings) comment (texpr : texpr) = 
     if s.DumpTAst then
-        printfn "\ndump typed abstract syntax tree:"
+        printfn "\n%s:" comment
         printfn "%A" texpr
     texpr
-
 
-let execCmd (s : settings) (ctx, env) = function
-    | Expr e ->
-        let tast' = TypeChecker.typify ctx e |> dumpTAst s
-        let tast = TypeChecker.erasure ctx tast' |> dumpTAst s
-        let frm = Emitter.emit tast |> dumpVmCode s
-        let v = VirtualMachine.run frm env
-        let x = Name "it"
-        ((x, tast.Type) :: ctx, (x, ref v) :: env), sprintf "val %O : %s = %s" x (string tast.Type) (string v)
+let inline dumpContext (s : settings) (ctx : context) =
+    if s.DumpContext then
+        printfn "\ndump context:"
+        printfn "%A" ctx
+    ctx
+
+let inline dumpEnv (s : settings) (env : VirtualMachine.env) =
+    if s.DumpEnv then
+        printfn "\ndump environment:"
+        printfn "%A" env
+    env
 
-    | LetBinding (x, e) ->
-         let tast' = TypeChecker.typify ctx e |> dumpTAst s
-         let tast = TypeChecker.erasure ctx tast' |> dumpTAst s
-         let frm = Emitter.emit tast |> dumpVmCode s
-         let v = VirtualMachine.run frm env
-         ((x, tast.Type) :: ctx, (x, ref v) :: env), sprintf "val %s : %s = %s" (string x) (string tast.Type) (string v)
+let execCmd (s : settings) (ctx, env) expr = 
+    let name, e = match expr with Expr e -> Name "it", e | LetBinding (x, e) -> x, e
+    let tast' = TypeChecker.typify ctx e |> dumpTAst s "dump typed abstract syntax tree"
+    let tast = TypeChecker.transform ctx tast' |> dumpTAst s "dump typed and transforment abstract syntax tree"
+    let frm = Emitter.emit tast |> dumpVmCode s
+    let v = VirtualMachine.run frm env
+    ((name, tast.Type) :: ctx, (name, ref v) :: env), sprintf "val %O : %s = %s" name (string tast.Type) (string v)
 
 
 let execCmds (s : settings) ce cmds =
@@ -70,9 +72,9 @@ let interactive (settings : settings) ctx env =
                 printf "NanoML> "
                 let str = System.Console.ReadLine()
                 let decls = Parser.toplevel Lexer.token (LexBuffer<_>.FromString str) |> dumpDeclarations settings
-                let (ctx, env) = execCmds settings (!globalCtx, !globalEnv) decls
-                globalCtx := ctx
-                globalEnv := env
+                let (ctx : context, env : VirtualMachine.env) = execCmds settings (!globalCtx, !globalEnv) decls
+                globalCtx := ctx |> dumpContext settings
+                globalEnv := env |> dumpEnv settings
                 ()
             with
                 | TypeChecker.TypeError msg -> printfn "Type error: %s" msg
@@ -88,18 +90,23 @@ let main (args : string array) =
     let dumpDecl = ref false
     let dumpVmCode = ref false
     let dumpTAst = ref false
+    let dumpContext = ref false
+    let dumpEnv = ref false
     let files = ref []
     ArgParser.Parse 
         ([ArgInfo("-n", ArgType.Set nonInteractive , "Non interactive run")
           ArgInfo("--DumpDecl", ArgType.Set dumpDecl, "Dump delcarations")
           ArgInfo("--DumpVMCode", ArgType.Set dumpVmCode, "Dump virtual machine code")
-          ArgInfo("--DumpTAst", ArgType.Set dumpTAst, "Dump typed AST")],
+          ArgInfo("--DumpTAst", ArgType.Set dumpTAst, "Dump typed AST")
+          ArgInfo("--DumpCtx", ArgType.Set dumpContext, "Dump context (Attention: printing may cycle when object graph has cycles)")
+          ArgInfo("--DumpEnv", ArgType.Set dumpEnv, "Dump environment")],
          (fun f -> files := f :: !files),
-         "Usage: nanoml [-n] [file] ...")
+         "Usage: nanoml [-n] [other options] [file] ...")
 
     try
-        let settings = { DumpDeclarations = !dumpDecl; DumpVMCode = !dumpVmCode; DumpTAst = !dumpTAst }
-        let ctx, env =
+        let settings = { DumpDeclarations = !dumpDecl; DumpVMCode = !dumpVmCode; 
+                         DumpTAst = !dumpTAst; DumpContext = !dumpContext; DumpEnv = !dumpEnv }
+        let (ctx : context), env =
             List.fold
                 (fun ce f ->
                     let text = File.ReadAllText f

src/NanoML/NanoML.fsproj

@@ -23,7 +23,7 @@
     <WarningLevel>3</WarningLevel>
     <PlatformTarget>x86</PlatformTarget>
     <DocumentationFile>bin\Debug\NanoML.XML</DocumentationFile>
-    <StartArguments>--DumpDecl --DumpVMCode --DumpTAst ../../../NanoML.Stdlib/stdlib.nanoml</StartArguments>
+    <StartArguments>--DumpDecl --DumpVMCode --DumpTAst --DumpCtx ../../../NanoML.Stdlib/stdlib.nanoml</StartArguments>
   </PropertyGroup>
   <PropertyGroup Condition=" '$(Configuration)|$(Platform)' == 'Release|x86' ">
     <DebugType>pdbonly</DebugType>

src/NanoML/NanoMLAst.fs

@@ -68,23 +68,3 @@ type expr =
 type toplevel_decl =
     | Expr of expr
     | LetBinding of name * expr
-
-(*
-
-let rec subst s = function
-    | Var x as e -> match List.assoc x s with Some v -> v | _ -> e
-    | (Int _ | Bool _ | Float _) as e -> e
-    | Times (e1, e2) -> Times(subst s e1, subst s e2)
-    | Plus (e1, e2) -> Plus(subst s e1, subst s e2)
-    | Minus (e1, e2) -> Minus (subst s e1, subst s e2)
-    | Divide (e1, e2) -> Divide(subst s e1, subst s e2)
-    | Equal (e1, e2) -> Equal (subst s e1, subst s e2)
-    | Less (e1, e2) -> Less (subst s e1, subst s e2)
-    | Cond (e1, e2, e3) -> Cond (subst s e1, subst s e2, subst s e3)
-    | Fun (f, x, tyIn, tyOut, e) ->
-        let s' = s |> List.removeAssoc x |> List.removeAssoc f
-        Fun(f, x, tyIn, tyOut, subst s' e)
-    | Apply (e1, e2) -> Apply (subst s e1, subst s e2)
-    | LetIn (var, e1, e2) -> LetIn(var, e1, subst ((var, e1) :: s) e2)
-
-*)

src/NanoML/NanoMLTAst.fs

@@ -22,7 +22,8 @@ type texpr =
         | TVar (_, ty) | TTimes (_, _, ty) | TPlus (_, _, ty) | TMinus (_, _, ty)
         | TDivide (_, _, ty) | TCond (_, _, _, ty) | TFun (_, _, _, _, _, ty) 
         | TApply (_, _, ty) | TLetIn (_, _, _, ty) -> ty
-        | TInt _ -> TyInt | TFloat _ -> TyFloat 
+        | TInt _ -> TyInt 
+        | TFloat _ -> TyFloat 
         | TBool _ | TEqual _ | TLess _ -> TyBool
 
 

src/NanoML/TypeChecker.fs

@@ -71,26 +71,26 @@ let cleanName ((Name n) as name) =
     if n = "_" then randName()
     else name
 
-let rec erasure ctx = function
+let rec transform ctx = function
     | TLetIn (x, texpr1, texpr2, ty) ->
         let name = randName()
         let ctx' = (name, TyFun(texpr1.Type, texpr2.Type)) :: ctx 
         let lambda = TFun(name, 
                           x,
                           texpr1.Type,
                           texpr2.Type, 
-                          erasure ctx' texpr2,
+                          transform ctx' texpr2,
                           TyFun(texpr1.Type, texpr2.Type))
 
         TApply(lambda, texpr1, texpr2.Type)
     | TVar _ | TInt _ | TFloat _ | TBool _ as e -> e
-    | TTimes (e1, e2, ty) -> TTimes (erasure ctx e1, erasure ctx e2, ty)
-    | TPlus (e1, e2, ty) -> TPlus (erasure ctx e1, erasure ctx e2, ty)
-    | TMinus (e1, e2, ty) -> TMinus (erasure ctx e1, erasure ctx e2, ty)
-    | TDivide (e1, e2, ty) -> TDivide (erasure ctx e1, erasure ctx e2, ty)
-    | TEqual (e1, e2) -> TEqual (erasure ctx e1, erasure ctx e2)
-    | TLess (e1, e2) -> TLess (erasure ctx e1, erasure ctx e2)
-    | TCond (e1, e2, e3, ty) -> TCond (erasure ctx e1, erasure ctx e2, erasure ctx e3, ty)
-    | TFun (f, x, ty1, ty2, e, ty) -> TFun (cleanName f, x, ty1, ty2, erasure ctx e, ty)
-    | TApply (e1, e2, ty) -> TApply (erasure ctx e1, erasure ctx e2, ty)
+    | TTimes (e1, e2, ty) -> TTimes (transform ctx e1, transform ctx e2, ty)
+    | TPlus (e1, e2, ty) -> TPlus (transform ctx e1, transform ctx e2, ty)
+    | TMinus (e1, e2, ty) -> TMinus (transform ctx e1, transform ctx e2, ty)
+    | TDivide (e1, e2, ty) -> TDivide (transform ctx e1, transform ctx e2, ty)
+    | TEqual (e1, e2) -> TEqual (transform ctx e1, transform ctx e2)
+    | TLess (e1, e2) -> TLess (transform ctx e1, transform ctx e2)
+    | TCond (e1, e2, e3, ty) -> TCond (transform ctx e1, transform ctx e2, transform ctx e3, ty)
+    | TFun (f, x, ty1, ty2, e, ty) -> TFun (cleanName f, x, ty1, ty2, transform ctx e, ty)
+    | TApply (e1, e2, ty) -> TApply (transform ctx e1, transform ctx e2, ty)
     | _ -> failwith "Not implemented yet"

src/NanoML/VM.fs

@@ -46,22 +46,18 @@ and instr =
     | ILessf
     | IConvF2I
     | IConvI2F
-    | ILdVar of name // push variable on stack
-    | ILdInt of int // push int constant on stack
-    | ILdFloat of float // push float constant on stack
-    | ILdBool of bool // push booleans constant on stack
-    | ILdClosure of name * name * frame // push closure on stack
+    | ILdVar of name
+    | ILdInt of int
+    | ILdFloat of float
+    | ILdBool of bool
+    | ILdClosure of name * name * frame
     | IBranch of frame * frame
     | ICall 
     | IPopEnv
 
 
 let frame2string (frm : frame) =
-    let rec loop frm =
-        match frm with
-        | h :: t -> sprintf "%A" h + "\n" + loop t
-        | [] -> ""
-    loop frm 
+    List.fold (fun res instr -> res + string instr + "\n") "" frm
 
 
 let error msg = raise (RuntimeError msg)
@@ -146,11 +142,11 @@ let execute instr frms stck (envs : env list) =
     | ILdBool v -> frms, MBool v :: stck, envs
     | IConvF2I -> frms, convf2i stck, envs
     | IConvI2F -> frms, convi2f stck, envs
-    | ILdClosure (f, x, frm) ->
+    | ILdClosure (funName, param, code) ->
         match envs with
         | env :: _ ->
             let c' = ref Unchecked.defaultof<mvalue>
-            let c = MClosure (x, frm, (f, c') :: env)
+            let c = MClosure (param, code, (funName, c') :: env)
             c' := c
             frms, c :: stck, envs
         | [] -> error "no environment for a closure"
@@ -160,8 +156,8 @@ let execute instr frms stck (envs : env list) =
         (if b then f1 else f2) :: frms, stck', envs
 
     | ICall ->
-        let x, frm, env, v, stck' = popApp stck
-        frm :: frms, stck', ((x, ref v) :: env) :: envs
+        let argName, code, env, arg, stck' = popApp stck
+        code :: frms, stck', ((argName, ref arg) :: env) :: envs
 
     | IPopEnv ->
          match envs with