diff --git a/build.fsx b/build.fsx index 2195ddc927..d6f98ae9d8 100644 --- a/build.fsx +++ b/build.fsx @@ -251,6 +251,35 @@ let buildLibraryRust() = runInDir buildDir ("cargo fmt") runInDir buildDir ("cargo build") +let buildLibraryC() = + let libraryDir = "src/fable-library-c" + let sourceDir = libraryDir "src" + let buildDir = "build/fable-library-c" + let fableLib = "." + + let outDir = buildDir "src" + + cleanDirs [buildDir] + + runFableWithArgs sourceDir [ + "--outDir " + resolveDir outDir + "--fableLib " + fableLib + "--lang C" + "--exclude Fable.Core" + "--define FABLE_LIBRARY" + ] + // Copy *.lua from projectDir to buildDir + copyFiles sourceDir "*.c" outDir + copyDirRecursive libraryDir buildDir + + runInDir buildDir ("gcc -v") + //runInDir buildDirLua ("lua ./setup.lua develop") + +let buildCLibraryIfNotExists() = + let baseDir = __SOURCE_DIRECTORY__ + if not (pathExists (baseDir "build/fable-library-c")) then + buildLibraryC() + let buildLibraryRustIfNotExists() = if not (pathExists (__SOURCE_DIRECTORY__ "build/fable-library-rust")) then buildLibraryRust() @@ -554,7 +583,7 @@ let testRust testMode = // limited cleanup to reduce IO churn, speed up rebuilds, // and save the ssd (target folder can get huge) cleanDirs [buildDir "src"] - cleanDirs [buildDir "tests"] + cleanDirs [buildDir "/"] cleanDirs [buildDir ".fable"] // copy rust only tests files (these must be present when running dotnet test as import expr tests for file presence) @@ -590,6 +619,28 @@ let testRust testMode = runInDir buildDir "cargo test" runInDir buildDir "cargo test --features threaded" +let testC() = + buildCLibraryIfNotExists() // NOTE: fable-library-c needs to be built separately. + + let projectDir = "tests/C" + let buildDir = "build/tests/C" + + cleanDirs [buildDir "tests"] + copyDirRecursive ("build" "fable-library-c" "src") (buildDir "fable-lib") + // runInDir projectDir "dotnet test" + runFableWithArgs projectDir [ + "--outDir " + buildDir + "--exclude Fable.Core" + "--lang C" + "--fableLib " + projectDir "fable-lib" + "--noCache" + ] + + // copyFile (projectDir "cunit.c") (buildDir "cunit.c") + // copyFile (projectDir "runtests.c") (buildDir "runtests.c") + runInDir buildDir "gcc ./tests/src/main.c -g" // -g gives debug symbols + runInDir buildDir "a.exe" + let testDart isWatch = if not (pathExists "build/fable-library-dart") then buildLibraryDart(true) @@ -776,6 +827,7 @@ match BUILD_ARGS_LOWER with | "test-rust-default"::_ -> testRust SingleThreaded | "test-rust-threaded"::_ -> testRust MultiThreaded | "test-rust-all"::_ -> testRust Everything +| "test-c"::_ -> testC() | "test-dart"::_ -> testDart(false) | "watch-test-dart"::_ -> testDart(true) @@ -819,6 +871,7 @@ match BUILD_ARGS_LOWER with | ("fable-library-ts"|"library-ts")::_ -> buildLibraryTs() | ("fable-library-py"|"library-py")::_ -> buildLibraryPy() | ("fable-library-rust" | "library-rust")::_ -> buildLibraryRust() +| ("fable-library-c" | "library-c")::_ -> buildLibraryC() | ("fable-library-dart" | "library-dart")::_ -> let clean = hasFlag "--no-clean" |> not buildLibraryDart(clean) diff --git a/src/Fable.AST/Plugins.fs b/src/Fable.AST/Plugins.fs index 9c5c636a5f..7640a21f7a 100644 --- a/src/Fable.AST/Plugins.fs +++ b/src/Fable.AST/Plugins.fs @@ -16,6 +16,7 @@ type Language = | Php | Dart | Rust + | C override this.ToString () = match this with @@ -25,6 +26,7 @@ type Language = | Php -> "PHP" | Dart -> "Dart" | Rust -> "Rust" + | C -> "C" type CompilerOptions = { diff --git a/src/Fable.Cli/Entry.fs b/src/Fable.Cli/Entry.fs index 49450bcee9..c3bd1c08f7 100644 --- a/src/Fable.Cli/Entry.fs +++ b/src/Fable.Cli/Entry.fs @@ -151,6 +151,7 @@ let argLanguage (args: CliArgs) = | "php" -> Php | "dart" -> Dart | "rs" | "rust" -> Rust + | "C" | "c" -> C | _ -> JavaScript) type Runner = @@ -236,6 +237,7 @@ type Runner = | Python -> "FABLE_COMPILER_PYTHON" | TypeScript -> "FABLE_COMPILER_TYPESCRIPT" | JavaScript -> "FABLE_COMPILER_JAVASCRIPT" + | C -> "FABLE_COMPILER_C" ] |> List.distinct @@ -363,6 +365,7 @@ let getStatus = function | Dart -> "beta" | TypeScript -> "alpha" | Php -> "experimental" + | C -> "experimental" [] let main argv = diff --git a/src/Fable.Cli/Pipeline.fs b/src/Fable.Cli/Pipeline.fs index e839565a92..f50584bc50 100644 --- a/src/Fable.Cli/Pipeline.fs +++ b/src/Fable.Cli/Pipeline.fs @@ -342,6 +342,24 @@ module Rust = do! RustPrinter.run writer crate } +module C = + open Fable.Transforms + + let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = async { + //com.LibraryDir <- cliArgs.FableLibraryPath todo + let program = + FSharp2Fable.Compiler.transformFile com + |> FableTransforms.transformFile com + |> Fable2C.transformFile com + + use headerWriter = new IO.StreamWriter(outPath.TrimEnd(".c".ToCharArray()) + ".h") + let ctxHeader = CPrinter.Output.Writer.create headerWriter + use fileWriter = new IO.StreamWriter(outPath) + let ctxFile = CPrinter.Output.Writer.create fileWriter + CPrinter.Output.writeHeaderFile ctxHeader program + CPrinter.Output.writeFile ctxFile program + } + let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPath: string) = match com.Options.Language with | JavaScript | TypeScript -> Js.compileFile com cliArgs pathResolver isSilent outPath @@ -349,3 +367,4 @@ let compileFile (com: Compiler) (cliArgs: CliArgs) pathResolver isSilent (outPat | Php -> Php.compileFile com cliArgs pathResolver isSilent outPath | Dart -> Dart.compileFile com cliArgs pathResolver isSilent outPath | Rust -> Rust.compileFile com cliArgs pathResolver isSilent outPath + | C -> C.compileFile com cliArgs pathResolver isSilent outPath diff --git a/src/Fable.Cli/ProjectCracker.fs b/src/Fable.Cli/ProjectCracker.fs index 8ba206ce90..458848ebec 100644 --- a/src/Fable.Cli/ProjectCracker.fs +++ b/src/Fable.Cli/ProjectCracker.fs @@ -602,6 +602,7 @@ let getFableLibraryPath (opts: CrackerOptions) = | _ -> "fable-library-py/fable_library", "fable_library" | Dart -> "fable-library-dart", "fable_library" | Rust -> "fable-library-rust", "fable-library-rust" + | C -> "fable-library-c", "fable-library-c" | TypeScript -> "fable-library-ts", "fable-library-ts" | _ -> "fable-library", "fable-library" + "." + Literals.VERSION diff --git a/src/Fable.Cli/Util.fs b/src/Fable.Cli/Util.fs index a5649e3905..d89c44ca9e 100644 --- a/src/Fable.Cli/Util.fs +++ b/src/Fable.Cli/Util.fs @@ -150,6 +150,7 @@ module File = | Fable.Dart -> ".dart" | Fable.Rust -> ".rs" | Fable.JavaScript -> ".js" + | Fable.C -> ".c" match language, usesOutDir with | Fable.Python, _ -> fileExt // Extension will always be .py for Python diff --git a/src/Fable.Transforms/C/C.fs b/src/Fable.Transforms/C/C.fs new file mode 100644 index 0000000000..fa625d1ca1 --- /dev/null +++ b/src/Fable.Transforms/C/C.fs @@ -0,0 +1,108 @@ +// fsharplint:disable MemberNames InterfaceNames + +namespace rec Fable.AST.C + + +type CType = + | Int + | Char + | ShortInt + | UnsignedShortInt + | LongInt + | UnsignedLongInt + | Float + | Double + | Void + | Array of CType + | Pointer of CType + | CStruct of string + | Rc of CType + | CTypeDef of string + + +type Const = + | ConstInt16 of int16 + | ConstInt32 of int32 + | ConstString of string + | ConstBool of bool + | ConstNull + + +type CIdent = + { Name: string; Type: CType } + +type UnaryOp = + | Not + | RefOf + +type BinaryOp = + | Equals + | Unequal + | Less + | LessOrEqual + | Greater + | GreaterOrEqual + | Multiply + | Divide + | Plus + | Minus + | BinaryTodo of string + | And + | Or + + + + +type Expr = + | Ident of CIdent + | Const of Const + | Unary of UnaryOp * Expr + | Binary of BinaryOp * Expr * Expr + | GetField of Expr * name: string + | GetFieldThroughPointer of Expr * name: string + | GetObjMethod of Expr * name: string + | GetAtIndex of Expr * idx: Expr + | SetValue of Expr * value: Expr + | SetExpr of Expr * Expr * value: Expr + | FunctionCall of f: Expr * args: Expr list + | Brackets of Expr + | Cast of CType * Expr + | AnonymousFunc of args: string list * body: Statement list + | Unknown of string + | Comment of string + | Macro of string * args: Expr list + | NoOp + // | Function of args: string list * body: Statement list + | NewArr of values: Expr list + + + + +type Statement = + // | FunctionDeclaration of name: string * args: string list * body: Statement list * returnType: CType + | DeclareIdent of name: string* assignType: CType + | Assignment of names: string list * Expr * assignType: CType + | Return of Expr * CType + | Do of Expr + | SNoOp + | ForLoop of string * start: Expr* limit: Expr* body: Statement list + | WhileLoop of guard: Expr * body: Statement list + | IfThenElse of guard: Expr * thenSt: Statement list * elseSt: Statement list + +type Include = + { + Name: string + IsBuiltIn : bool + } + +type Declaration = + | FunctionDeclaration of name: string * args: (string * CType) list * body: Statement list * returnType: CType + | StructDeclaration of name: string * params: (string * CType) list + | NothingDeclared + | TypedefFnDeclaration of name: string * args: (string * CType) list * returnType: CType + +type File = + { Filename: string + Includes: Include list + Declarations: Declaration list + ASTDebug: string } \ No newline at end of file diff --git a/src/Fable.Transforms/C/CPrinter.fs b/src/Fable.Transforms/C/CPrinter.fs new file mode 100644 index 0000000000..032a108155 --- /dev/null +++ b/src/Fable.Transforms/C/CPrinter.fs @@ -0,0 +1,509 @@ +module Fable.Transforms.CPrinter + +open System +open System.IO +open Fable +open Fable.AST +open Fable.AST.C + +module Output = + + type Writer = + { Writer: TextWriter + Indent: int + Precedence: int + CurrentNamespace: string option } + + + module Helper = + let separateWithCommas = function + | [] -> "" + | [x] -> x + | lst -> lst |> List.reduce (fun acc item -> acc + " ," + item) + + + + + let indent ctx = + { ctx with Indent = ctx.Indent + 1} + + module Writer = + let create w = + { Writer = w; Indent = 0; Precedence = Int32.MaxValue; CurrentNamespace = None } + + + let writeIndent ctx = + for _ in 1 .. ctx.Indent do + ctx.Writer.Write(" ") + + let write ctx txt = + ctx.Writer.Write(txt: string) + + + let writei ctx txt = + writeIndent ctx + write ctx txt + + let writeln ctx txt = + ctx.Writer.WriteLine(txt: string) + + let writeCommented ctx help txt = + writeln ctx "/*" + write ctx help + writeln ctx txt + writeln ctx "*/" + + let writeCommentedShort ctx txt = + write ctx "/*" + write ctx txt + write ctx "*/" + + let writeOp ctx = function + | Multiply -> write ctx "*" + | Equals -> write ctx "==" + | Unequal -> write ctx "!=" + | Less -> write ctx "<" + | LessOrEqual -> write ctx "<=" + | Greater -> write ctx ">" + | GreaterOrEqual -> write ctx ">=" + | Divide -> write ctx """/""" + | Plus -> write ctx "+" + | Minus -> write ctx "-" + | And -> write ctx "&&" + | Or -> write ctx "||" + | BinaryTodo x -> writeCommented ctx "binary todo" x + + let sprintExprSimple = function + | Ident i -> i.Name + | _ -> "" + + let rec writeType ctx = function + | Int -> + write ctx "int" + | Char -> + write ctx "char" + | Void -> write ctx "void" + | Pointer t -> + writeType ctx t + write ctx "* " + | Array t -> + writeType ctx t + write ctx " " + write ctx "array[]" + | CStruct name -> + write ctx "struct " + write ctx name + | Rc _ -> + write ctx "struct Rc" + // + | CTypeDef td -> write ctx td + | x -> sprintf "%A" x |> write ctx + + let rec writeExpr ctx = function + | Ident i -> + write ctx i.Name + | Const c -> + match c with + | ConstString s -> s |> sprintf "\"%s\"" |> write ctx + | ConstInt16 n -> n |> sprintf "%i" |> write ctx + | ConstInt32 n -> n |> sprintf "%i" |> write ctx + | ConstBool b -> b |> sprintf "%b" |> write ctx + | ConstNull -> write ctx "NULL" + + | FunctionCall(e, args) -> + writeExpr ctx e + write ctx "(" + args |> writeExprs ctx + write ctx ")" + | AnonymousFunc(args, body) -> + write ctx "(function " + write ctx "(" + args |> Helper.separateWithCommas |> write ctx + write ctx ")" + writeln ctx "" + let ctxI = indent ctx + for b in body do + writeStatement ctxI b + writei ctx "end)" + | Unary(op, expr) -> + let op = + match op with + | Not -> "!" + | RefOf -> "&" + write ctx op + writeExpr ctx expr + | Binary (op, left, right) -> + writeExpr ctx left + write ctx " " + writeOp ctx op + write ctx " " + writeExpr ctx right + | GetField(expr, fieldName) -> + writeExpr ctx expr + write ctx "." + write ctx fieldName + | GetFieldThroughPointer(expr, fieldName) -> + writeExpr ctx expr + write ctx "->" + write ctx fieldName + | GetObjMethod(expr, fieldName) -> + writeExpr ctx expr + write ctx ":" + write ctx fieldName + | GetAtIndex(expr, idx) -> + writeExpr ctx expr + write ctx "[" + writeExpr ctx idx + write ctx "]" + | SetValue(expr, value) -> + writeExpr ctx expr + write ctx " = " + writeExpr ctx value + | SetExpr(expr, a, value) -> + writeExpr ctx expr + write ctx " = " + + // writeExpr ctx a + + // write ctx " " + + writeExpr ctx value + + // | Ternary(guardExpr, thenExpr, elseExpr) -> + + // write ctx "(" + // writeExpr ctx guardExpr + // let ctxI = indent ctx + // write ctx " and " + // writeExpr ctxI thenExpr + // write ctx " or " + // writeExpr ctxI elseExpr + // write ctx ")" + + | Macro (macro, args) -> + let regex = System.Text.RegularExpressions.Regex("\$(?\d)(?\.\.\.)?") + let matches = regex.Matches(macro) + let mutable pos = 0 + for m in matches do + let n = int m.Groups.["n"].Value + write ctx (macro.Substring(pos,m.Index-pos)) + if m.Groups.["s"].Success then + if n < args.Length then + match args.[n] with + | NewArr items -> + let mutable first = true + for value in items do + if first then + first <- false + else + write ctx ", " + writeExpr ctx value + | _ -> + writeExpr ctx args.[n] + + + + + elif n < args.Length then + writeExpr ctx args.[n] + + pos <- m.Index + m.Length + write ctx (macro.Substring(pos)) + // | Function(args, body) -> + // write ctx "function " + // write ctx "(" + // args |> Helper.separateWithCommas |> write ctx + // write ctx ")" + // let ctxI = indent ctx + // writeln ctxI "" + // body |> List.iter (writeStatement ctxI) + // writei ctx "end" + + // | NewStructInst(args) -> + // write ctx "{" + // let ctxI = indent ctx + // writeln ctxI "" + // for idx, (name, expr) in args |> List.mapi (fun i x -> i, x) do + // writei ctxI name + // write ctxI " = " + // writeExpr ctxI expr + // if idx < args.Length - 1 then + // writeln ctxI "," + // writeln ctx "" + // writei ctx "}" + + | NewArr(args) -> + write ctx "{" + let ctxI = indent ctx + writeln ctxI "" + for idx, expr in args |> List.mapi (fun i x -> i, x) do + writei ctxI "" + writeExpr ctxI expr + if idx < args.Length - 1 then + writeln ctxI "," + + //writeExprs ctxI args + + writeln ctx "" + writei ctx "}" + + | NoOp -> () + | Brackets expr -> + write ctx "(" + writeExpr ctx expr + write ctx ")" + | Cast (t, expr) -> + write ctx "(" + writeType ctx t + write ctx ")" + write ctx "(" + writeExpr ctx expr + write ctx ")" + | Unknown x -> + writeCommented ctx "unknown" x + | Comment c -> + writeCommentedShort ctx c + + and writeExprs ctx = function + + | [] -> () + + | h::t -> + + writeExpr ctx h + + for item in t do + + write ctx ", " + + writeExpr ctx item + + + + + and writeStatement ctx = function + | DeclareIdent(name, assignType) -> + writei ctx "" + writeType ctx assignType + write ctx " " + write ctx name + writeln ctx ";" + | Assignment(names, expr, assignType) -> + let names = names |> Helper.separateWithCommas + writei ctx "" + writeType ctx assignType + write ctx " " + write ctx names + write ctx " = " + writeExpr ctx expr + writeln ctx ";" + | Return (expr, _) -> + writei ctx "return " + writeExpr ctx expr + writeln ctx ";" + + | Do expr -> + writei ctx "" + writeExpr ctx expr + writeln ctx ";" + | ForLoop (name, start, limit, body) -> + writei ctx "for " + write ctx name + write ctx "=" + writeExpr ctx start + write ctx ", " + writeExpr ctx limit + write ctx " do" + let ctxI = indent ctx + writeln ctxI "" + for statement in body do + writeStatement ctxI statement + writeln ctx "" + writei ctx "end" + writeln ctx ";" + + | WhileLoop (guard, body) -> + writei ctx "while " + writeExpr ctx guard + write ctx " do" + let ctxI = indent ctx + writeln ctxI "" + for statement in body do + writeStatement ctxI statement + writeln ctx "" + writei ctx "end" + writeln ctx ";" + + | IfThenElse(guard, thenSt, elseSt) -> + writei ctx "if (" + writeExpr ctx guard + write ctx ") {" + let ctxI = indent ctx + writeln ctxI "" + for statement in thenSt do + writeStatement ctxI statement + writei ctx "}" + writeln ctx "" + writei ctx "else {" + writeln ctxI "" + for statement in elseSt do + writeStatement ctxI statement + writei ctx "}" + writeln ctx "" + + | SNoOp -> () + + let rec writeHeaderDeclaration ctx declaration = + match declaration with + | FunctionDeclaration(name, args, body, returnType) -> + writei ctx "" + writeType ctx returnType + write ctx " " + write ctx name + write ctx "(" + // let args = if exportToMod then "self"::args else args + let mutable first = true + for (arg, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx arg + // args |> Helper.separateWithCommas |> write ctx + write ctx ");" + writeln ctx "" + | StructDeclaration(name, fields) -> + writei ctx "" + write ctx "struct " + write ctx name + write ctx " {" + let ctxI = indent ctx + writeln ctxI "" + for (name, t) in fields do + writei ctxI "" + writeType ctxI t + write ctxI " " + write ctxI name + writeln ctxI ";" + writeln ctx "};" + | TypedefFnDeclaration(name, args, returnArg) -> + write ctx "typedef " + writeType ctx returnArg + write ctx " " + let mutable first = true + // write ctx ("(*" + name + ")") + write ctx name + write ctx " (" + for (name, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx name + writeln ctx ");" + | NothingDeclared _ -> () + + let rec writeDeclaration ctx declaration = + match declaration with + | FunctionDeclaration(name, args, body, returnType) -> + writei ctx "" + writeType ctx returnType + write ctx " " + write ctx name + write ctx "(" + // let args = if exportToMod then "self"::args else args + let mutable first = true + for (arg, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx arg + // args |> Helper.separateWithCommas |> write ctx + write ctx ") {" + let ctxI = indent ctx + writeln ctxI "" + body |> List.iter (writeStatement ctxI) + writeln ctx "}" + | StructDeclaration(name, fields) -> + writei ctx "" + write ctx "struct " + write ctx name + write ctx " {" + let ctxI = indent ctx + writeln ctxI "" + for (name, t) in fields do + writei ctxI "" + writeType ctxI t + write ctxI " " + write ctxI name + writeln ctxI ";" + writeln ctx "};" + | TypedefFnDeclaration(name, args, returnArg) -> + write ctx "typedef " + writeType ctx returnArg + write ctx " " + let mutable first = true + // write ctx ("(*" + name + ")") + write ctx name + write ctx " (" + for (name, t) in args do + if not first then + write ctx ", " + first <- false + writeType ctx t + write ctx " " + write ctx name + writeln ctx ");" + | NothingDeclared _ -> () + + let writeHeaderFile ctx (file: File) = + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#ifndef %s" |> writeln ctx + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#define %s" |> writeln ctx + for fInclude in file.Includes do + if fInclude.IsBuiltIn then + sprintf "#include <%s>" fInclude.Name |> writei ctx + writeln ctx "" + else + sprintf "#include \"%s\"" (fInclude.Name.Replace(".c", ".h")) |> writei ctx + writeln ctx "" + for s in file.Declarations do + writeHeaderDeclaration ctx s + writeln ctx "" + writeln ctx "#endif" + + let writeFile ctx (file: File) = + // writeln ctx "#include " + // writeln ctx "#include " + // writeln ctx "#include \"../../fable-lib/rc.c\"" // todo imports should handle this + //todo write includes + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#ifndef %s" |> writeln ctx + file.Filename.Replace(".","_").Replace("/", "_").Replace(":", "_") |> sprintf "#define %s" |> writeln ctx + + let useHFiles = false + for fInclude in file.Includes do + if fInclude.IsBuiltIn then + sprintf "#include <%s>" fInclude.Name |> writei ctx + writeln ctx "" + else + if useHFiles then + sprintf "#include \"%s\"" (fInclude.Name.Replace(".c", ".h")) |> writei ctx + else + sprintf "#include \"%s\"" fInclude.Name |> writei ctx + writeln ctx "" + for s in file.Declarations do + writeDeclaration ctx s + writeln ctx "" + + writeln ctx "#endif" + + // writeln ctx "--[[" + + // sprintf "%s" file.ASTDebug |> write ctx + + //sprintf "%A" file.Statements |> write ctx + + //writeln ctx " --]]" \ No newline at end of file diff --git a/src/Fable.Transforms/C/Compiler.fs b/src/Fable.Transforms/C/Compiler.fs new file mode 100644 index 0000000000..01409e9e2f --- /dev/null +++ b/src/Fable.Transforms/C/Compiler.fs @@ -0,0 +1,156 @@ +module rec Fable.Compilers.C + +open Fable +open Fable.AST +open Fable.AST.Fable + +module CHelpers = + let clone outExpr = C.FunctionCall(C.Ident { Name = "Rc_Clone" ; Type = C.Void }, [outExpr]) + +type CCompiler(com: Fable.Compiler) = + + let mutable types = Map.empty + let mutable decisionTreeTargets = [] + let mutable additionalDeclarations = [] + let mutable includes = Set.empty + let mutable identSubstitutions = Map.empty + //member this.Com = com + // member this.AddClassDecl (c: ClassDecl) = + // types <- types |> Map.add c.Entity c + // member this.GetByRef (e: EntityRef) = + // types |> Map.tryFind e + member this.DecisionTreeTargets (exprs: (list * Expr) list) = + decisionTreeTargets <- exprs + member this.GetDecisionTreeTargets (idx: int) = decisionTreeTargets.[idx] + member this.GetEntity entRef= com.TryGetEntity(entRef).Value + member this.GetMember = com.GetMember + // member _.MakeImportPath(path) = + // let projDir = System.IO.Path.GetDirectoryName(cliArgs.ProjectFile) + // let path = Imports.getImportPath pathResolver sourcePath targetPath projDir cliArgs.OutDir path + // if path.EndsWith(".fs") then Path.ChangeExtension(path, fileExt) else path + member this.GenFunctionSignatureAlias (args, retType) = + let seed = + let v = args.GetHashCode() + retType.GetHashCode() + if v < 0 then -v else v//todo prevent collisions + let declName = "function_" + seed.ToString(); + let declaration = C.TypedefFnDeclaration(declName, args |> List.mapi (fun i a -> "p_"+i.ToString(), a), retType) + additionalDeclarations <- + additionalDeclarations @ [declaration] + C.CTypeDef declName + + member this.GenAndCallDeferredFunctionFromExpr (scopedArgs, body, retType) = + let seed = + let v = scopedArgs.GetHashCode() + body.GetHashCode() + if v < 0 then -v else v//todo prevent collisions + let delegatedName = "delegated_" + seed.ToString() //todo generate procedurally + let declaration = C.FunctionDeclaration( + delegatedName, + scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type), + body, + retType) + additionalDeclarations <- additionalDeclarations @ [declaration] + C.FunctionCall(C.Ident {Name = delegatedName; Type = C.Void }, scopedArgs |> List.map C.Ident) + member this.GenAndCallDeferredClosureFromExpr (lambdaType: Fable.Type, scopedArgs: C.CIdent list, closedOverIdents: (string * C.CType) list, body, retType) = + let seed = + let v = scopedArgs.GetHashCode() + body.GetHashCode() + if v < 0 then -v else v//todo prevent collisions + let hasCaptures = closedOverIdents |> List.isEmpty |> not + let delegatedName = "fn_with_closed_" + seed.ToString() + let structCapturesNm = "closure_struct_captures_" + seed.ToString() + let structClosureNm = "closure_struct_" + seed.ToString() + let self = C.CStruct "FnClosure1" |> C.Rc + let functionDeclaration = + let bindClosedValsBody = [ + if hasCaptures then + let structType = C.CStruct "FnClosure1" // todo need to defer as chicken and egg problem + let expr = C.Ident { Name = "self"; Type = C.Rc structType} + let unwrappedSelf = C.Brackets(C.GetField(C.Cast(structClosureNm |> C.CStruct |> C.Pointer, expr), "data")) + C.Assignment(["captures"], C.GetFieldThroughPointer(unwrappedSelf, "captures") |> CHelpers.clone, C.CStruct structCapturesNm |> C.Rc) + for (name, ctype) in closedOverIdents do + let unwrappedCapt = C.Brackets(C.GetField(C.Cast(structCapturesNm |> C.CStruct |> C.Pointer, C.Ident {Name = "captures"; Type = C.CStruct structCapturesNm}), "data")) + C.Assignment([name], C.GetFieldThroughPointer(unwrappedCapt, name) |> CHelpers.clone ,ctype) + ] + C.FunctionDeclaration( + delegatedName, + ("self", self)::(scopedArgs |> List.map (fun (s: C.CIdent) -> s.Name, s.Type)), + //closedOverIdents, + bindClosedValsBody @ body, + retType) + + let fsParams = (scopedArgs |> List.map (fun s -> s.Type)) @ (closedOverIdents |> List.map snd) + let identParam = "fn", this.GenFunctionSignatureAlias(self::fsParams, retType) |> C.Pointer + let structCapturesDeclaration = C.StructDeclaration( + structCapturesNm, + closedOverIdents + ) + let structClosureDeclaration = C.StructDeclaration( + structClosureNm, + [ + identParam + if hasCaptures then + "captures", C.Rc (C.CStruct structCapturesNm) + ] + ) + let newStructClosureDeclaration = C.FunctionDeclaration( + structClosureNm + "_new", + closedOverIdents, + [ + C.DeclareIdent("item", structClosureNm |> C.CStruct) + C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, "fn"), C.Ident {Name = delegatedName; Type = C.Void})) + if hasCaptures then + C.DeclareIdent("captures", structCapturesNm |> C.CStruct) + for (name, ctype) in closedOverIdents do + C.Do(C.SetValue(C.GetField(C.Ident {Name = "captures"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) + C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, "captures"), + C.FunctionCall(C.Ident { Name="Rc_New"; Type= C.Void}, + [ + + C.FunctionCall(C.Ident { Name = "sizeof"; Type = C.Void }, [ C.Ident {Name = "captures"; Type = C.Void} ]) + C.Unary(C.UnaryOp.RefOf, C.Ident {Name = "captures"; Type = C.Void} ) + C.Const C.ConstNull + ] + ))) + // for (name, ctype) in closedOverIdents do + // C.Do(C.SetValue(C.GetField(C.Ident {Name = "item"; Type = C.Void;}, name), C.Ident {Name = name; Type = C.Void})) + C.Assignment(["rc"], + C.FunctionCall(C.Ident { Name="Rc_New"; Type= C.Void}, + [ + + C.FunctionCall(C.Ident { Name = "sizeof"; Type = C.Void }, [ C.Ident { Name = "item"; Type = C.Void }]) + C.Unary(C.UnaryOp.RefOf, C.Ident { Name = "item"; Type = C.Void }) + C.Const C.ConstNull + ] + ), + C.Rc (structClosureNm |> C.CStruct)) + C.Return (C.Ident { Name = "rc"; Type = structClosureNm |> C.CStruct |> C.Rc}, structClosureNm |> C.CStruct |> C.Rc) + ], + C.Rc C.Void + ) + additionalDeclarations <- + additionalDeclarations + @ [ + if hasCaptures then + structCapturesDeclaration + structClosureDeclaration + functionDeclaration + newStructClosureDeclaration ] + + //struct with captures + C.FunctionCall(C.Ident {Name = structClosureNm + "_new"; Type = C.Void }, + closedOverIdents |> List.map (fun (name, t) -> C.Ident {Name = name; Type = t }) |> List.map CHelpers.clone) + member this.GetAdditionalDeclarations() = + additionalDeclarations + |> List.distinct + member this.GetAdditionalDeclarationsAndClear() = + let decs = additionalDeclarations + |> List.distinct + additionalDeclarations <- [] + decs + member this.RegisterInclude(fInclude: Fable.AST.C.Include) = + // failwithf "%A" com.LibraryDir + includes <- includes |> Set.add fInclude + member this.RegisterIdentSubstitution (oldIdent: string, newIdent: string) = + identSubstitutions <- identSubstitutions |> Map.add oldIdent newIdent + member this.GetIdentSubstitution oldValue = + identSubstitutions |> Map.tryFind oldValue |> Option.defaultValue oldValue + member this.GetIncludes() = includes |> Set.toList \ No newline at end of file diff --git a/src/Fable.Transforms/C/Fable2C.fs b/src/Fable.Transforms/C/Fable2C.fs new file mode 100644 index 0000000000..488c311aa8 --- /dev/null +++ b/src/Fable.Transforms/C/Fable2C.fs @@ -0,0 +1,841 @@ +module rec Fable.Transforms.Fable2C + +//cloned from FableToBabel + +open System +open System.Collections.Generic +open System.Text.RegularExpressions + +open Fable +open Fable.AST +open Fable.AST.C +open Fable.Compilers.C +open Fable.Naming +open Fable.Core + + +module Transforms = + module Helpers = + let transformStatements transformStatements transformReturn exprs = [ + match exprs |> List.rev with + | h::t -> + for x in t |> List.rev do + yield transformStatements x + yield transformReturn h + | [] -> () + ] + let ident name t = Ident { Name = name; Type = t } + let voidIdent name = ident name Void + let fcall args expr= FunctionCall(expr, args) + let iife statements = FunctionCall(AnonymousFunc([], statements), []) + let debugLog expr = FunctionCall(Helpers.ident "print" Void, [expr]) |> Do + let libEquality a b= + FunctionCall(GetObjMethod(FunctionCall(Helpers.ident "require" Void, [ConstString "./fable-lib/Util" |> Const]), "equals"), [a; b]) + let maybeIife = function + | [] -> NoOp + | [Return (expr, _)] -> expr + | statements -> iife statements + + module Out = + open Fable.AST.C + let rec identUsesInExpr = function + | FunctionCall(f, args) -> + f::args |> List.map identUsesInExpr |> List.collect id + | Unary(_, expr) -> + identUsesInExpr expr + | GetField(expr, name) -> + identUsesInExpr expr + | Ident i -> + [i] + | Const(_) -> [] + | Binary(_, l, r) -> identUsesInExpr l @ identUsesInExpr r + | GetObjMethod(expr, name) -> identUsesInExpr expr + | GetAtIndex(expr, idx) -> identUsesInExpr expr + | SetValue(expr, value) -> identUsesInExpr expr @ identUsesInExpr value + | SetExpr(a, b, value) -> identUsesInExpr a @ identUsesInExpr b @ identUsesInExpr value + | Brackets(expr) -> identUsesInExpr expr + | AnonymousFunc(args, body) -> failwith "Not Implemented" + | Unknown(_) -> [] + | Macro(_, args) -> args |> List.collect identUsesInExpr + // | Ternary(guardExpr, thenExpr, elseExpr) -> + // identUsesInExpr guardExpr @ identUsesInExpr thenExpr @ identUsesInExpr elseExpr + | NoOp -> [] + // | Function(args, body) -> failwith "Not Implemented" + | NewArr(values) -> + values |> List.collect identUsesInExpr + | GetFieldThroughPointer(expr, name) -> + identUsesInExpr expr + | Cast(_, expr) -> + identUsesInExpr expr + | Comment(_) -> [] + let rec identUsesInSingleStatement = function + | Return (expr, _) -> identUsesInExpr expr + | Do expr -> identUsesInExpr expr + | DeclareIdent(_, _) -> [] + | Assignment(names, expr, _) -> identUsesInExpr expr + | SNoOp -> [] + | ForLoop(_, start, limit, body) -> + (identUsesInExpr start) @ (identUsesInExpr limit) @ (body |> List.collect identUsesInSingleStatement) + | WhileLoop(guard, body) -> + (identUsesInExpr guard) @ (body |> List.collect identUsesInSingleStatement) + | IfThenElse(guard, thenSt, elseSt) -> + (identUsesInExpr guard) @ (thenSt |> List.collect identUsesInSingleStatement) @ (elseSt |> List.collect identUsesInSingleStatement) + let identUsesInStatements = + List.collect identUsesInSingleStatement + >> Set.ofList + let unwrapRc tOut expr= + Brackets(GetField(Cast(tOut |> Pointer, expr), "data")) + + + + let statementsToExpr (com: CCompiler) retType = function + | [] -> NoOp + | [Return (expr, _)] -> + expr + | lst -> + let identsToCapture = identUsesInStatements lst + com.GenAndCallDeferredFunctionFromExpr(identsToCapture |> Set.toList, lst, retType) + // | lst -> + // let captures = [] + // com.CreateAdditionalDeclaration(FunctionDeclaration()) + // let addCleanupOnExit (com: CCompiler) t args statements = + // let locallyDeclaredIdents = + // statements |> List.choose(function + // | DeclareIdent(name, Rc t) -> Some (name, t) + // | _ -> None) + // let rcArgs = args |> List.filter (function + // | _, Rc t -> true + // | _ -> false ) + // let rationalizedStatements = + // //there should only be a return statement in the tail call position + // match statements |> List.rev with + // | h::t -> + // let tNext = + // t |> List.map(function + // | Return x -> Do x + // | x -> x) + // (h::tNext) |> List.rev + // let toCleanup = rcArgs @ locallyDeclaredIdents + // [ + // for s in rationalizedStatements do + // match s with + // | Return r -> // where the scope ends, add clean up + // // yield! toCleanup + // // yield DeclareIdent("ret", t) + // if toCleanup.Length > 0 then + // yield Assignment(["ret"],r, t) + // //cleanup + // for (name, t) in toCleanup do + // yield FunctionCall("Rc_Dispose" |> voidIdent, [Ident {Name = name; Type = t}]) |> Do + // yield Return (Ident { Name="ret"; Type=t }) + // else + // yield Return r + // | IfThenElse(guard, thenSt, elseSt) -> + // yield IfThenElse(guard, thenSt, elseSt) //addCleanupOnExit com t toCleanup thenSt/elseSt + // | _ -> yield s + // ] + + let getEntityFieldsAsIdents (ent: Fable.Entity): Fable.Ident list = + ent.FSharpFields + |> Seq.map (fun field -> + let name = field.Name + let typ = FableTransforms.uncurryType field.FieldType + let id: Fable.Ident = { makeTypedIdent typ name with IsMutable = field.IsMutable } + id) + |> Seq.toList + + module FCalls = + let newRc expr t = + match t with + | C.Int -> + FunctionCall(Ident { Name="Rc_New_Int"; Type = t}, + [ + expr + ] + ) + | _ -> + FunctionCall(Ident { Name="Rc_New"; Type = t}, + [ + FunctionCall( + Helpers.voidIdent "sizeof",[ expr ]) + Unary(UnaryOp.RefOf, expr) + Const ConstNull + ] + ) + //from rs + let isClosedOverIdent com ctx (ident: Fable.Ident) = + true + //from rs + let getIgnoredNames (name: string option) (args: Fable.Ident list) = + let argNames = args |> List.map (fun arg -> arg.Name) + let allNames = name |> Option.fold (fun xs x -> x :: xs) argNames + allNames |> Set.ofList + + //from rs + let tryFindClosedOverIdent com ctx (ignoredNames: HashSet) expr = + match expr with + | Fable.IdentExpr ident -> + if not (ignoredNames.Contains(ident.Name)) + && (isClosedOverIdent com ctx ident) + then Some ident + else None + // add local names in the closure to the ignore list + // TODO: not perfect, local name shadowing will ignore captured names + | Fable.ForLoop(ident, _, _, _, _, _) -> + ignoredNames.Add(ident.Name) |> ignore + None + | Fable.Lambda(arg, _, _) -> + ignoredNames.Add(arg.Name) |> ignore + None + | Fable.Delegate(args, body, name, _) -> + args |> List.iter (fun arg -> + ignoredNames.Add(arg.Name) |> ignore) + None + | Fable.Let(ident, _, _) -> + ignoredNames.Add(ident.Name) |> ignore + None + | Fable.LetRec(bindings, _) -> + bindings |> List.iter (fun (ident, _) -> + ignoredNames.Add(ident.Name) |> ignore) + None + | Fable.DecisionTree(_, targets) -> + targets |> List.iter (fun (idents, _) -> + idents |> List.iter (fun ident -> + ignoredNames.Add(ident.Name) |> ignore)) + None + | _ -> + None + + //from rs + let getCapturedIdents com ctx (name: string option) (args: Fable.Ident list) (body: Fable.Expr) = + let ignoredNames = HashSet(getIgnoredNames name args) + let mutable capturedIdents = Map.empty + let addClosedOver expr = + tryFindClosedOverIdent com ctx ignoredNames expr + |> Option.iter (fun ident -> + capturedIdents <- capturedIdents |> Map.add ident.Name ident + ) + false + // collect all closed over names that are not arguments + deepExists addClosedOver body |> ignore + capturedIdents + + let transformValueKind (com: CCompiler) = function + | Fable.NumberConstant(v, kind,_) -> + let c = + match kind, v with + | Int16, (:? int16 as x) -> + ConstInt16(x) + | Int32, (:? int32 as x) -> + ConstInt32(x) + | _ -> ConstNull + Const(c) + | Fable.StringConstant(s) -> + FunctionCall(Ident { Name="Rc_New"; Type= Char }, [ + ConstInt32(s.Length) |> Const + ConstString s |> Const + Const ConstNull + ]) + //Const(ConstString s) + | Fable.BoolConstant(b) -> + Const(ConstBool b) + | Fable.UnitConstant -> + Const(ConstNull) + | Fable.CharConstant(c) -> + Const(ConstString (string c)) + // | Fable.EnumConstant(e,ref) -> + // convertExpr com e + | Fable.NewRecord(values, ref, args) -> + let entity = com.GetEntity(ref) + if entity.IsFSharpRecord then + let names = entity.FSharpFields |> List.map(fun f -> f.Name) + let values = values |> List.map (transformExpr com) + FunctionCall(Ident({ Name = entity.FullName.Replace(".", "_") + "_new"; Type = C.Void}), values) + else sprintf "unknown ety %A %A %A %A" values ref args entity |> Unknown + | Fable.NewAnonymousRecord(values, names, _, _) -> + let transformedValues = values |> List.map (transformExpr com) + FunctionCall(Ident({ Name = "anon" + "_new"; Type = C.Void}), transformedValues) + | Fable.NewUnion(values, tag, entRef, _) -> + let entity = com.GetEntity(entRef) + let values = values |> List.map(transformExpr com) + let tagM = entity.UnionCases[tag] + FunctionCall(Ident({ Name = entity.FullName.Replace(".", "_") + "_" + tagM.Name + "_new"; Type = C.Void}), values) + | Fable.NewOption (value, t, _) -> + value |> Option.map (transformExpr com) |> Option.defaultValue (Const ConstNull) + | Fable.NewTuple(values, isStruct) -> + // let fields = values |> List.mapi(fun i x -> sprintf "p_%i" i, transformExpr com x) + // NewObj(fields) + NewArr(values |> List.map (transformExpr com)) + | Fable.NewArray(Fable.ArrayValues values, t, _) -> + NewArr(values |> List.map (transformExpr com)) + | Fable.Null _ -> + Const(ConstNull) + | x -> sprintf "unknown %A" x |> ConstString |> Const + + let transformType (com: CCompiler) (t: Fable.Type) = + let tOut = + match t with + | Fable.Type.Char -> Char + | Fable.Type.Number(kind, info) -> + match kind with + | Int32 -> + Int + | _ -> Void + | Fable.Type.String -> + Rc (Char) + | Fable.Type.Unit -> + Void + | Fable.Type.DeclaredType (entRef, genArgs) -> + let ent = com.GetEntity entRef + if ent.IsFSharpRecord then + if ent.IsValueType then + ent.FullName.Replace(".", "_") |> CStruct + else + ent.FullName.Replace(".", "_") |> CStruct |> Rc + elif ent.IsFSharpUnion then + ent.FullName.Replace(".", "_") |> CStruct |> Rc + else Pointer Void + | Fable.Type.GenericParam(name, false, constraints) -> + Rc Void + | Fable.Type.LambdaType(arg, returnType) -> + Rc Void + | _ -> + sprintf "unrecognised %A" t |> CStruct + tOut + let isRcType (com: CCompiler) t = + let cType = transformType com t + match cType with + | Rc _ -> true + | _ -> false + let transformCallIdentsWithTypes com = + List.filter(fun (ident: Fable.Ident) -> match ident.Type with | Fable.Unit -> false | _ -> true) + >> List.map(fun ident -> ident.Name, transformType com ident.Type) + let transformOp com = + let transformExpr = transformExpr com + function + | Fable.OperationKind.Binary(BinaryModulus, left, right) -> + GetField(Helpers.ident "math" Void, "fmod") |> Helpers.fcall [transformExpr left; transformExpr right] + | Fable.OperationKind.Binary (op, left, right) -> + let op = match op with + | BinaryMultiply -> Multiply + | BinaryDivide -> Divide + | BinaryEqual -> Equals + | BinaryPlus -> Plus + | BinaryMinus -> Minus + | BinaryEqualStrict -> Equals + | BinaryUnequal -> Unequal + | BinaryUnequalStrict -> Unequal + | BinaryLess -> Less + | BinaryGreater -> Greater + | BinaryLessOrEqual -> LessOrEqual + | BinaryGreaterOrEqual -> GreaterOrEqual + | x -> sprintf "%A" x |> BinaryTodo + Binary(op, transformExpr left, transformExpr right ) + | Fable.OperationKind.Unary (op, expr) -> + match op with + | UnaryNotBitwise -> transformExpr expr //not sure why this is being added + | UnaryNot -> Unary(Not, transformExpr expr) + | UnaryVoid -> NoOp + | _ -> sprintf "%A %A" op expr |> Unknown + | x -> Unknown(sprintf "%A" x) + + let shouldBox expectedType (actualType: Fable.Type) = + match expectedType, actualType with + | Fable.Type.GenericParam _, Fable.Type.Number _ -> + true + | Fable.Type.GenericParam _, Fable.Type.Boolean _ -> + true + | _ -> false + + let transformCallArgs (com: CCompiler) (memberRef: Fable.AST.Fable.MemberRef option) args= + match args with + | [] -> [] + | [MaybeCasted(Fable.Value(Fable.UnitConstant, _))] -> [] + | args -> + let parameters = + memberRef |> Option.map com.GetMember |> Option.map (fun m -> m.CurriedParameterGroups |> List.concat) |> Option.defaultValue [] + + args |> List.mapi (fun idx arg -> + let shouldBox = parameters |> List.tryItem idx |> Option.map (fun p -> shouldBox p.Type arg.Type) |> Option.defaultValue false + if shouldBox then + FCalls.newRc (transformLeaveContext com arg) (transformType com arg.Type) + else transformLeaveContext com arg + ) + + let transformExprAsStatements (com: CCompiler) (expr: Fable.Expr) : Statement list = + let transformExpr = transformExpr com + let transformOp = transformOp com + let singletonStatement outExpr = + match expr.Type with + | Fable.Type.Unit -> [Do outExpr] + | _ -> [Return (outExpr, transformType com expr.Type)] + + match expr with + | Fable.Expr.Value(value, _) -> transformValueKind com value |> singletonStatement + | Fable.Expr.Call(expr, callInfo, t, r) -> + let lhs = + match expr with + // | Fable.Expr.IdentExpr i -> + // let ptr = + // transformExpr expr |> Helpers.Out.unwrapRc Void + // GetFieldThroughPointer(ptr, "fn") + | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> + match t with + | Fable.DeclaredType(_, _) + | Fable.AnonymousRecordType(_, _, _) -> + GetObjMethod(transformExpr expr, fi.Name) + | _ -> transformExpr expr + | Fable.Expr.Delegate _ -> + transformExpr expr |> Brackets + | _ -> transformExpr expr + + let args = transformCallArgs com callInfo.MemberRef callInfo.Args + //let mref = callInfo.MemberRef |> Option.map com.GetMember + //sprintf "%A" expr |> Unknown |> singletonStatement + FunctionCall(lhs, args) |> singletonStatement + | Fable.Expr.Import (info, t, r) -> + // match info.Kind, info.Path with + // | LibraryImport, Regex "fable-lib\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/" + name + // | LibraryImport, Regex "fable-library-c\/fable\/fable-library\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/fable-library" + name + // | LibraryImport, Regex "fable-library-c\/fable\/(\w+).(?:fs|js)" [name] -> + // "fable-lib/" + name + // | _ -> + // info.Path.Replace(".fs", "").Replace(".js", "") //todo - make less brittle + com.RegisterInclude({Name = info.Path.Replace(".fs",".c"); IsBuiltIn = false}) + let fullName = + match info.Kind with + | Fable.UserImport _ -> info.Selector + | Fable.LibraryImport x -> info.Selector + | Fable.MemberImport m -> + let mm = com.GetMember m + mm.FullName.Replace(".", "_") + | Fable.ClassImport c -> + c.FullName.Replace(".", "_") + + Ident { Name = fullName; Type = transformType com t } |> singletonStatement + | Fable.Expr.IdentExpr(i) when i.Name <> "" -> + let name = com.GetIdentSubstitution i.Name + Ident { Name = name; Type = transformType com i.Type } |> singletonStatement + | Fable.Expr.Operation (kind, _, _, _) -> + transformOp kind |> singletonStatement + | Fable.Expr.Get(expr, Fable.GetKind.FieldGet(fi), t, _) -> + match transformType com expr.Type with + | Rc tOut -> + let ptr = + transformExpr expr |> Helpers.Out.unwrapRc tOut + GetFieldThroughPointer(ptr, fi.Name) + | _ -> + GetField(transformExpr expr, fi.Name) + |> singletonStatement + | Fable.Expr.Get(expr, Fable.GetKind.UnionField(fi), _, _) -> + let outExpr = transformExpr expr + let ety = com.GetEntity fi.Entity + let case = ety.UnionCases |> List.item fi.CaseIndex + let structName = ety.FullName.Replace(".", "_") + "_" + case.Name + let ptr = Helpers.Out.unwrapRc (CStruct structName) outExpr + let field = case.UnionCaseFields |> List.item fi.FieldIndex + //failwithf "%A" (case, ety, ety.UnionCases, expr.Type) + GetFieldThroughPointer(ptr, field.Name) |> singletonStatement + | Fable.Expr.Get(expr, Fable.GetKind.ExprGet(e), _, _) -> + GetAtIndex(transformExpr expr, transformExpr e) |> singletonStatement + | Fable.Expr.Get(expr, Fable.GetKind.TupleIndex(i), _, _) -> + GetAtIndex(transformExpr expr, Const (ConstInt32 i)) |> singletonStatement + | Fable.Expr.Get(expr, Fable.GetKind.OptionValue, _, _) -> + transformExpr expr |> singletonStatement //todo null check, throw if null? + | Fable.Expr.Set(expr, Fable.SetKind.ValueSet, t, value, _) -> + SetValue(transformExpr expr, transformExpr value) |> singletonStatement + | Fable.Expr.Set(expr, Fable.SetKind.ExprSet(e), t, value, _) -> + SetExpr(transformExpr expr, transformExpr e, transformExpr value) |> singletonStatement + | Fable.Expr.Sequential exprs -> + exprs |> List.map (transformExprAsStatements com) |> List.collect id + | Fable.Expr.Let (ident, value, body) -> + let shouldBox = shouldBox ident.Type value.Type + let outType = + if shouldBox then transformType com value.Type |> Rc else transformType com value.Type + [ + yield sprintf "%A" value.Type |> Comment |> Do + yield Assignment([ident.Name], transformExpr value, outType) + yield! transformExprAsStatements com body + ] + | Fable.Expr.Emit(m, _, _) -> + // let argsExprs = m.CallInfo.Args |> List.map transformExpr + // let macroExpr = Macro(m.Macro, argsExprs) + // let exprs = + // argsExprs + // @ [macroExpr] + // asSingleExprIife exprs + Macro(m.Macro, m.CallInfo.Args |> transformCallArgs com m.CallInfo.MemberRef) |> singletonStatement + | Fable.Expr.DecisionTree(expr, lst) -> + com.DecisionTreeTargets(lst) + transformExpr expr |> singletonStatement + | Fable.Expr.DecisionTreeSuccess(i, boundValues, _) -> + let idents,target = com.GetDecisionTreeTargets(i) + if idents.Length = boundValues.Length then + let statements = + [ for (ident, value) in List.zip idents boundValues do + yield Assignment([ident.Name], transformExpr value, transformType com value.Type) + yield Return (transformExpr target, transformType com target.Type) + ] + statements + // |> Helpers.maybeIife + else sprintf "not equal lengths %A %A" idents boundValues |> Unknown |> singletonStatement + | Fable.Expr.Lambda(arg, body, name) -> + //let closedOverIdents + let bodyStmnts = transformExprAsStatements com body + let identsToCapture = + getCapturedIdents com () None [arg] body + |> Map.toList + |> List.map (snd >> fun ident -> ident.Name, ident.Type |> transformType com) + let res = com.GenAndCallDeferredClosureFromExpr( + expr.Type, + [{Name = arg.Name; Type = transformType com arg.Type}], + identsToCapture, + bodyStmnts, + transformType com body.Type) + // [ sprintf "%A" expr.Type |> Comment |> Do ] + // @ (res |> singletonStatement) + res |> singletonStatement + // Function([arg.Name], transformExprAsStatements com body) |> singletonStatement + | Fable.Expr.CurriedApply(applied, args, t, _) -> + match applied with + | Fable.Expr.IdentExpr i -> + // i.Type + //todo need to get to + //struct Rc resr2 = ((struct delegatedclosure_1742910231*)f.data)->fn(x); + //let tOut = com.GenFunctionSignatureAlias(args |> List.map (fun a -> a.Type |> transformType com), transformType com t) + let ptr = + transformExpr applied + let ptrUnwrapped = + let closureTmpl = CStruct "FnClosure1" + ptr + |> Helpers.Out.unwrapRc closureTmpl + let tagValExpr = GetFieldThroughPointer(ptrUnwrapped, "fn") + let called = FunctionCall(tagValExpr, ptr::(args |> List.map transformExpr) |> List.map CHelpers.clone) + [ + sprintf "%A" i.Type |> Comment |> Do + ] @ (singletonStatement called) + // sprintf "%A" expr |> Unknown |> singletonStatement + | _ -> + FunctionCall(transformExpr applied, args |> List.map transformExpr) |> singletonStatement + | Fable.Expr.IfThenElse (guardExpr, thenExpr, elseExpr, _) -> + [IfThenElse(transformExpr guardExpr, transformExprAsStatements com thenExpr, transformExprAsStatements com elseExpr)] + | Fable.Test(expr, kind, b) -> + match kind with + | Fable.UnionCaseTest i-> + match expr.Type with + | Fable.DeclaredType(entRef, genArgs) -> + let ent = com.GetEntity(entRef) + assert(ent.IsFSharpUnion) + let unionCase = ent.UnionCases |> List.head + let structName = ent.FullName.Replace(".", "_") + "_" + unionCase.Name + let tOut = CStruct (structName) + let ptr = + transformExpr expr |> Helpers.Out.unwrapRc tOut + let tagValExpr = GetFieldThroughPointer(ptr, "tag") + Binary(Equals, tagValExpr , Const (ConstInt32 i)) |> singletonStatement + | _ -> + Binary(Equals, GetField(transformExpr expr, "tag") , Const (ConstInt32 i)) |> singletonStatement + | Fable.OptionTest isSome -> + if isSome then Binary(Unequal, Const ConstNull, transformExpr expr) else Binary(Equals, Const ConstNull, transformExpr expr) + |> singletonStatement + | Fable.TestKind.TypeTest t -> + // match t with + // | Fable.DeclaredType (ent, genArgs) -> + // match ent.FullName with + // | Fable.Transforms.Types.ienumerable -> //isArrayLike + // | Fable.Transforms.Types.array + // | _ -> + // | _ -> () + Binary(Equals, GetField(transformExpr expr, "type"), Const (t.ToString() |> ConstString)) + |> singletonStatement + | _ -> + Unknown(sprintf "test %A %A" expr kind) + |> singletonStatement + | Fable.Extended(Fable.ExtendedSet.Throw(expr, _), t) -> + // let errorExpr = + // Const (ConstString ("There was an error, todo " + sprintf "%A" expr)) + //transformExpr expr + FunctionCall(Helpers.ident "error" Void, expr |> Option.map transformExpr |> Option.toList) + |> singletonStatement + | Fable.Extended(Fable.ExtendedSet.Curry(expr, d), _) -> + transformExpr expr + |> sprintf "todo curry %A" + |> Unknown + |> singletonStatement + | Fable.Delegate(idents, body, _, _) -> + // Function(idents |> List.map(fun i -> i.Name), transformExprAsStatements com body) //can be flattened + // |> singletonStatement + sprintf "%A" expr |> Unknown |> singletonStatement + | Fable.ForLoop(ident, start, limit, body, isUp, _) -> + [ForLoop(ident.Name, transformExpr start, transformExpr limit, transformExprAsStatements com body)] + | Fable.TypeCast(expr, t) -> + transformExprAsStatements com expr //typecasts are meaningless + | Fable.WhileLoop(guard, body, range) -> + [ + WhileLoop(transformExpr guard, transformExprAsStatements com body) + ] + | Fable.TryCatch(body, catch, finalizer, _) -> + [ + // Assignment(["status"; "resOrErr"], FunctionCall(Helpers.ident "pcall" Void, [ + // Function([], [ + // transformExpr body |> Return + // ]) + // ]), transformType com body.Type) + let finalizer = finalizer |> Option.map transformExpr + let catch = catch |> Option.map (fun (ident, expr) -> ident.Name, transformExpr expr, transformType com expr.Type) + IfThenElse(Helpers.ident "status" Void, [ + match finalizer with + | Some finalizer -> yield Do finalizer + | None -> () + yield Return (Helpers.ident "resOrErr" Void, Void) + ], [ + match catch with + | Some(ident, expr, t) -> + yield Return (expr, t) + | _ -> () + ]) + ] + | x -> [Unknown (sprintf "%A" x) |> Do] + let transformExpr com expr = + let retType = transformType com expr.Type + transformExprAsStatements com expr + |> Helpers.Out.statementsToExpr com retType + + let transformLeaveContext com expr = + let outExpr = transformExpr com expr + let isOnlyReference = + match expr with + | Fable.Let _ + | Fable.Call _ + | Fable.CurriedApply _ + | Fable.Value(_, _) + | Fable.Operation(Fable.Binary _, _, _, _) + | Fable.Lambda _ + | Fable.Delegate _ + | Fable.IfThenElse _ + | Fable.DecisionTree _ + | Fable.DecisionTreeSuccess _ + | Fable.Sequential _ + | Fable.ForLoop _ -> + true + | _ -> false + if isRcType com expr.Type && not (isOnlyReference) then + FunctionCall(Helpers.voidIdent("Rc_Clone"), [outExpr]) + else outExpr + + let transformDeclarations (com: CCompiler) = function + | Fable.ModuleDeclaration m -> + [] + | Fable.MemberDeclaration m -> + // if m.Args.Length = 0 then + // Assignment([m.Name], transformExpr com m.Body, transformType com m.Body.Type) + // else + + // let unwrapSelfExStatements = + // match transformExpr com m.Body |> Return |> flattenReturnIifes with + // | Return (FunctionCall(AnonymousFunc([], statements), [])) -> + // statements + // | s -> [s] + // match m.MemberRef with + // | MemberRef(ety, _) -> com.GetEntity(ety) + // failwithf "%A" m + let mr = com.GetMember(m.MemberRef) + let isEntryPoint = mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome + let t = transformType com m.Body.Type + let args = if isEntryPoint then [] else m.Args |> transformCallIdentsWithTypes com + let body = transformExprAsStatements com m.Body// |> Helpers.Out.addCleanupOnExit com t args + let finalName = + if mr.Attributes |> Seq.tryFind (fun att -> att.Entity.FullName = Atts.entryPoint) |> Option.isSome then + "main" + else + mr.FullName.Replace(".", "_") + com.RegisterIdentSubstitution(mr.CompiledName, finalName) + [FunctionDeclaration(finalName, args, body, t)] + | Fable.ClassDeclaration(d) -> + let ent = com.GetEntity(d.Entity) + if ent.IsFSharpRecord then + if ent.IsValueType then + let idents = Transforms.Helpers.getEntityFieldsAsIdents ent + let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) + let cdIdent = { Name = "item"; Type = Void } + [ + StructDeclaration(ent.FullName.Replace(".", "_"), fields) + FunctionDeclaration(ent.FullName.Replace(".", "_") + "_new", fields, [ + DeclareIdent("item", ent.FullName.Replace(".", "_") |> CStruct) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident {Name = "item"; Type = Void;}, name), Ident {Name = name; Type = Void})) + Return (Ident cdIdent, cdIdent.Type) + ], ent.FullName.Replace(".", "_") |> CStruct) + ] + else + let idents = Transforms.Helpers.getEntityFieldsAsIdents ent + let fields = idents |> List.map (fun i -> i.Name, transformType com i.Type) + let cdIdent = { Name = "item"; Type = ent.FullName.Replace(".", "_") |> CStruct } + let rcIdent = { Name = "rc"; Type = ent.FullName.Replace(".", "_") |> CStruct |> Rc} + [ + StructDeclaration(ent.FullName.Replace(".", "_"), fields) + FunctionDeclaration(ent.FullName.Replace(".", "_") + "_new", fields, [ + DeclareIdent("item", ent.FullName.Replace(".", "_") |> CStruct) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) + Assignment(["rc"], + FCalls.newRc (Helpers.voidIdent "item") Void, + // FunctionCall(Ident { Name="Rc_New"; Type= Void}, + // [ + // FunctionCall( + // Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + // Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + // Const ConstNull + // ] + // ), + Rc (ent.FullName.Replace(".", "_") |> CStruct)) + Return (Ident rcIdent, rcIdent.Type) + ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) + ] + elif ent.IsFSharpUnion then + [ + for i, case in ent.UnionCases |> List.mapi (fun i x -> i, x) do + let fields = + case.UnionCaseFields + |> List.map (fun f -> f.Name, transformType com f.FieldType) + let fieldsIncTag = + ["tag", Int] @ fields + let structName = ent.FullName.Replace(".", "_") + "_" + case.Name + yield StructDeclaration(structName, fieldsIncTag) + yield FunctionDeclaration(structName + "_new", fields, [ + let cdIdent = { Name = "item"; Type = CStruct structName } + let rcIdent = { Name = "rc"; Type = Rc (CStruct structName)} + DeclareIdent("item", CStruct structName) + Do(SetValue(GetField(Ident cdIdent, "tag"), ConstInt32 i |> Const)) + for (name, ctype) in fields do + Do(SetValue(GetField(Ident cdIdent, name), Ident {Name = name; Type = ctype})) + Assignment(["rc"], + // FunctionCall(Ident { Name="Rc_New"; Type= Void}, + // [ + // FunctionCall( + // Helpers.voidIdent "sizeof",[ Helpers.voidIdent "item"]) + // Unary(UnaryOp.RefOf, Helpers.voidIdent "item") + // Const ConstNull + // ] + // ), + FCalls.newRc (Helpers.voidIdent "item") Void, + Rc (ent.FullName.Replace(".", "_") |> CStruct)) + Return (Ident rcIdent, rcIdent.Type) + ], Rc (ent.FullName.Replace(".", "_") |> CStruct)) + ] + else + [] + | x -> [] + +let rec sanitizeReturnStatements = function + | h::[] -> + h::[] + | h::t -> + let hNext = + match h with + | Return (expr, t) -> + Do expr + | h -> h + hNext::(sanitizeReturnStatements t) + | [] -> [] + + +let transformDeclPostprocess = function + | FunctionDeclaration(name, args, statements, Void) -> + let statements = + statements + |> List.filter(function + | Return (Const ConstNull, _) -> false + | Do (Const(ConstNull)) -> false + | _ -> true) + let statements = sanitizeReturnStatements statements + FunctionDeclaration(name, args, statements, Void) + | x -> x + +let rec collectNewStatementsWithCleanup (ownedRcIdents, statementsOutRev, hasCleanedUp) statements = + // let recurse = findIdentsWithRc + match statements with + | h::t -> + let acc = + match h with + | DeclareIdent (name, Rc t) -> + ((name, t)::ownedRcIdents, h::statementsOutRev, false) + | Assignment ([name], _, Rc t) -> + ((name, t)::ownedRcIdents, h::statementsOutRev, false) + | Return (expr, t) -> + let statements = [ + let ownedRcIdents = + match expr with + | C.Ident i -> //if we return this, we transfer ownership, so do not clean up + ownedRcIdents |> List.filter(fun (name, _) -> name <> i.Name) + | _ -> ownedRcIdents + if ownedRcIdents.Length > 0 then + yield Assignment(["ret"], expr, t) + //cleanup + for (name, t) in ownedRcIdents do + yield FunctionCall("Rc_Dispose" |> Transforms.Helpers.voidIdent, [Ident {Name = name; Type = t}]) |> Do + yield Return (Ident { Name="ret"; Type= t }, t) + else + yield Return (expr, t) + ] + (ownedRcIdents, (statements |> List.rev) @ statementsOutRev, true) + | IfThenElse (guard, thenSt, elseSt) -> + let (_, thenStRev, _) = collectNewStatementsWithCleanup (ownedRcIdents, [], false) thenSt + let (_, elseStRev, _) = collectNewStatementsWithCleanup (ownedRcIdents, [], false) elseSt + (ownedRcIdents, IfThenElse(guard, thenStRev |> List.rev, elseStRev |> List.rev)::statementsOutRev, true) + | _ -> + (ownedRcIdents, h::statementsOutRev, false) + collectNewStatementsWithCleanup acc t + | [] -> + if hasCleanedUp then + (ownedRcIdents, statementsOutRev, true) + else + let statements = [ + for (name, t) in ownedRcIdents do + yield FunctionCall("Rc_Dispose" |> Transforms.Helpers.voidIdent, [Ident {Name = name; Type = t}]) |> Do + ] + (ownedRcIdents, (statements |> List.rev) @ statementsOutRev, true) + +let buildNewStatementsWithGc args statements = + let (idents, statementsOutRev, _) = collectNewStatementsWithCleanup (args, [], false) statements + List.rev statementsOutRev + +let transformDeclGc = function + | FunctionDeclaration(name, args, statements, t) -> + let argsWithOwnedRc = args |> List.filter(function | name, Rc t -> true | _ -> false) + let statements = buildNewStatementsWithGc argsWithOwnedRc statements + FunctionDeclaration(name, args, statements, t) + | x -> x + +let transformSanitizeReturnStatements = function + | FunctionDeclaration(name, args, statements, t) -> + let statements = sanitizeReturnStatements statements + FunctionDeclaration(name, args, statements, t) + | x -> x + +let transformFile com (file: Fable.File): File = + let builtInIncludes = + [ + { Name = "stdio.h"; IsBuiltIn = true } + { Name = "assert.h"; IsBuiltIn = true } + { Name = getLibPath com "native"; IsBuiltIn = false } + { Name = getLibPath com "closure"; IsBuiltIn = false } + { Name = getLibPath com "rc"; IsBuiltIn = false } + ] + let comp = CCompiler(com) + + let declarations = + file.Declarations + |> List.collect (fun dec -> + let stdDecs = Transforms.transformDeclarations comp dec + let additionalDecs = comp.GetAdditionalDeclarationsAndClear() + additionalDecs @ stdDecs) + |> List.map (transformDeclPostprocess >> transformDeclGc >> transformSanitizeReturnStatements) + { + Filename = com.CurrentFile + Includes = builtInIncludes @ comp.GetIncludes() + Declarations = declarations + ASTDebug = sprintf "%A" file.Declarations + } \ No newline at end of file diff --git a/src/Fable.Transforms/C/README.md b/src/Fable.Transforms/C/README.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/Fable.Transforms/Fable.Transforms.fsproj b/src/Fable.Transforms/Fable.Transforms.fsproj index 09a8e7c96d..ffb3e73a5d 100644 --- a/src/Fable.Transforms/Fable.Transforms.fsproj +++ b/src/Fable.Transforms/Fable.Transforms.fsproj @@ -39,6 +39,10 @@ + + + + diff --git a/src/Fable.Transforms/Transforms.Util.fs b/src/Fable.Transforms/Transforms.Util.fs index dcebbebad8..ec927ecf3c 100644 --- a/src/Fable.Transforms/Transforms.Util.fs +++ b/src/Fable.Transforms/Transforms.Util.fs @@ -596,6 +596,7 @@ module AST = com.LibraryDir + "/" + moduleName' + ".py" | Rust -> com.LibraryDir + "/" + moduleName + ".rs" | Dart -> com.LibraryDir + "/" + moduleName + ".dart" + | C -> com.LibraryDir + "/" + moduleName + ".c" | _ -> com.LibraryDir + "/" + moduleName + ".js" let makeImportUserGenerated r t (selector: string) (path: string) = diff --git a/src/fable-library-c/Readme.md b/src/fable-library-c/Readme.md new file mode 100644 index 0000000000..e69de29bb2 diff --git a/src/fable-library-c/src/Fable.Library.fsproj b/src/fable-library-c/src/Fable.Library.fsproj new file mode 100644 index 0000000000..0f1a5e57b7 --- /dev/null +++ b/src/fable-library-c/src/Fable.Library.fsproj @@ -0,0 +1,16 @@ + + + + netstandard2.0 + $(DefineConstants);FABLE_COMPILER + + + + + + + + + + + diff --git a/src/fable-library-c/src/Util.c b/src/fable-library-c/src/Util.c new file mode 100644 index 0000000000..05dfbe6300 --- /dev/null +++ b/src/fable-library-c/src/Util.c @@ -0,0 +1,11 @@ +#include "./rc.c" +#include + +#ifndef Util_C +#define Util_C + +bool equals(struct Rc a, struct Rc b) { + return a.data == b.data; +} + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/closure.c b/src/fable-library-c/src/closure.c new file mode 100644 index 0000000000..3bb8739fed --- /dev/null +++ b/src/fable-library-c/src/closure.c @@ -0,0 +1,12 @@ +#include "./rc.c" + +#ifndef Closure_C +#define Closure_C + +// Currently not directly used for creation, only as casting templates +typedef struct Rc(*fn1)(struct Rc self, struct Rc p_0); +struct FnClosure1 { + fn1 fn; +}; + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/native.c b/src/fable-library-c/src/native.c new file mode 100644 index 0000000000..d8cbfcaff6 --- /dev/null +++ b/src/fable-library-c/src/native.c @@ -0,0 +1,14 @@ +#include + +#ifndef Native_C +#define Native_C + +struct String { + char *Data; +}; + +// struct String String_new() { +// str +// } + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/rc.c b/src/fable-library-c/src/rc.c new file mode 100644 index 0000000000..58764b7c47 --- /dev/null +++ b/src/fable-library-c/src/rc.c @@ -0,0 +1,82 @@ +#include + +#ifndef Rc_C +#define Rc_C + +struct Rc { + void *data; + int (*dispose) (void *data); + int *count; +}; + +struct Rc Rc_New(int size, void *data, void *dispose(void *data)) { + struct Rc rc; + rc.count = malloc(sizeof(int)); + *rc.count = 1; + rc.data = malloc(size); + rc.dispose = dispose; + memcpy(rc.data, data, size); + return rc; +}; + +struct Rc Rc_New_Int(int data) { + struct Rc rc; + rc.count = malloc(sizeof(int)); + *rc.count = 1; + rc.data = malloc(4); + memcpy(rc.data, &data, 4); + return rc; +}; + +struct Rc Rc_Clone(struct Rc value) { + //struct Rc* rc = (struct Rc*) value; + *value.count = *value.count + 1; + struct Rc next; + next.count = value.count; + next.data = value.data; + return next; +} + +int Rc_Dispose(struct Rc value) { + *value.count = *value.count - 1; + if(*value.count == 0){ + if(value.dispose != NULL) + value.dispose(value.data); + free(value.data); + free(value.count); + } + return *value.count; +} + +// how to use + +// This is a .NET reference type +struct __Example_Use_Rc_Struct { + int X; +}; + +int __example_use_rc() { + //Create a new instance + struct __Example_Use_Rc_Struct test; + test.X = 1; + struct Rc rc = Rc_New(sizeof(test), &test, NULL); + + //Leave context, ownership + struct Rc rc2 = Rc_Clone(rc); + + //dereference + int outVal = ((struct __Example_Use_Rc_Struct *)(rc2.data))->X; + // (Test*) + + //Go out of scope, clean up + Rc_Dispose(rc); + Rc_Dispose(rc2); + + return 1; +} + +struct __Example_Use_Rc_Struct_Complex { + struct Rc a; //__Example_Use_Rc_Struct +}; + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/rc.h b/src/fable-library-c/src/rc.h new file mode 100644 index 0000000000..05769eb6b7 --- /dev/null +++ b/src/fable-library-c/src/rc.h @@ -0,0 +1,18 @@ +#include + +#ifndef Rc_H +#define Rc_H + +struct Rc { + void *data; + int (*dispose) (void *data); + int *count; +}; + +struct Rc Rc_New(int size, void *data, void *dispose(void *data)); + +struct Rc Rc_Clone(struct Rc value); + +int Rc_Dispose(struct Rc value); + +#endif \ No newline at end of file diff --git a/src/fable-library-c/src/string.c b/src/fable-library-c/src/string.c new file mode 100644 index 0000000000..7cb16f29ca --- /dev/null +++ b/src/fable-library-c/src/string.c @@ -0,0 +1,54 @@ +#include +#include "./rc.c" + +struct Rc String_New(char *inStr) { + return Rc_New(strlen(inStr), inStr, NULL); +} + +//get field pattern +char* String_Get_Char(struct Rc rc) { + char* data = rc.data; + return data; +} + +struct Rc String_Concat(struct Rc left, struct Rc right) { + int newSz = strlen(left.data) + strlen(right.data); + char* next = malloc(newSz); + strcpy(next, left.data); + strcat(next, right.data); + Rc_Dispose(left); + Rc_Dispose(right); + return String_New(next); +} + +// pattern to wrap a struct in an Rc +struct W_String { + char *data; +}; + +struct Rc W_String_New(char *inStr) { + struct W_String str; + str.data = malloc(strlen(inStr)); + return Rc_New(sizeof(str), &str, W_String_Dispose); +} + +//get field pattern +char* W_String_Get_Char(struct Rc rc) { + char* data = ((struct W_String *)rc.data)->data; + Rc_Dispose(rc); + return data; +} + +struct Rc W_String_Concat(struct Rc left, struct Rc right) { + int newSz = strlen(((struct W_String *)left.data)) + strlen(((struct W_String *)right.data)); + char* next = malloc(newSz); + strcpy(next, (struct W_String*)left.data); + strcat(next, ((struct W_String*)right.data)->data); + Rc_Dispose(left); + Rc_Dispose(right); + return W_String_New(next); +} + +void W_String_Dispose(void *data){ + free(((struct W_String *)(data))->data); +} \ No newline at end of file diff --git a/src/fable-standalone/src/Fable.Standalone.fsproj b/src/fable-standalone/src/Fable.Standalone.fsproj index ed89a8ebe0..5ff3dd15df 100644 --- a/src/fable-standalone/src/Fable.Standalone.fsproj +++ b/src/fable-standalone/src/Fable.Standalone.fsproj @@ -51,6 +51,10 @@ + + + + diff --git a/tests/C/Fable.Tests.C.fsproj b/tests/C/Fable.Tests.C.fsproj new file mode 100644 index 0000000000..fb69875c6a --- /dev/null +++ b/tests/C/Fable.Tests.C.fsproj @@ -0,0 +1,26 @@ + + + net6.0 + false + false + + + + + + runtime; build; native; contentfiles; analyzers; buildtransitive + all + + + + + + + + + + + + + + diff --git a/tests/C/tests/src/ArithmeticTests.fs b/tests/C/tests/src/ArithmeticTests.fs new file mode 100644 index 0000000000..0745f761e7 --- /dev/null +++ b/tests/C/tests/src/ArithmeticTests.fs @@ -0,0 +1,22 @@ +module ArithmeticTests +open Util + +let testAddition () = + let res = 2 + 2 + assertTrue(res = 4) + 1 + +let testSubtraction () = + let res = 4 - 1 + assertTrue(res = 3) + 1 + +let testMultiply () = + let res = 2 * 3 + assertTrue(res = 6) + 1 + +let testDivide () = + let res = 10 / 2 + assertTrue(res = 5) + 1 \ No newline at end of file diff --git a/tests/C/tests/src/ArrayTests.fs b/tests/C/tests/src/ArrayTests.fs new file mode 100644 index 0000000000..701ab7d84e --- /dev/null +++ b/tests/C/tests/src/ArrayTests.fs @@ -0,0 +1,2 @@ +module ArrayTests +open Util \ No newline at end of file diff --git a/tests/C/tests/src/RunTests.fs b/tests/C/tests/src/RunTests.fs new file mode 100644 index 0000000000..597c42e838 --- /dev/null +++ b/tests/C/tests/src/RunTests.fs @@ -0,0 +1,92 @@ +module RunTests + +open Fable.Core +open Util + + +[] +type Simple1 = { + X: int + Y: int +} + +let create y = + { X = 1; Y = y} + +let m () = + let x = 1 + 1 + { X = x; Y = 2 } + +let another x = + let b = 2 + x + 1 + b + +type Simple2 = { + X: int + Y: int +} + +let addBoth a b = + { X = a.X + b.X ; Y = a.Y + b.Y} +let forwardToAddBoth x = + addBoth {X = 1; Y = 2} x +let addMore i a b = + let first = a.X + b.X + i + let second = a.Y + b.Y + i + first + { X = first ; Y = second } +let condition1 x = + if x.X = 1 then + if x.Y > 3 then + 2 + else 4 + else 3 + +type DU = + | A + | B of int + | C of a: int * b: int + +let stuff () = + let m = A + let n = B 4 + n + +let matchstuff = function + | A -> 0 + | B i -> i + | C _ -> 1 + +let genericMap f x = + f x + +let testGenericMap () = + let res = genericMap (fun x -> { X = x.X + 1; Y = x.Y + 1}) { X = 1; Y = 1 } + // assertTrue(res = { X = 2; Y = 2}) + assertTrue(res.X = 2) + assertTrue(res.Y = 2) + () + +let testGenericMapWithClosure () = + let capt = { X = 3; Y = 4 } + let res = genericMap (fun x -> + { X = x.X + 1 + capt.X; Y = x.Y + 1 + capt.Y}) { X = 1; Y = 1 } + assertTrue(res.X = 5) + assertTrue(res.Y = 6) + () + +// Currently this cannot work as generics are represented as Rc +// let testGenericMap2 () = +// let res = genericMap (fun x -> x + 1) 1 +// assertTrue(res = 2) +// () + +// let papplyfn a b = +// a.X + b.X + +// let testCurriedApply () = +// let f1 = papplyfn { X = 1; Y = 0 } +// let res = f1 {X = 2; Y = 0} +// let res2 = f1 {X = 3; Y = 0} +// assertTrue(res = 3) +// assertTrue(res2 = 4) +// () \ No newline at end of file diff --git a/tests/C/tests/src/StringTests.fs b/tests/C/tests/src/StringTests.fs new file mode 100644 index 0000000000..9ed417087d --- /dev/null +++ b/tests/C/tests/src/StringTests.fs @@ -0,0 +1,12 @@ +module StringTests +open Util + +// let concat a b = +// a + " " + b + +let testStringConcatWorks () = + // let a = "hello" + // let b = "world" + // let r = concat a b + // assertTrue(r = "hello world") + () \ No newline at end of file diff --git a/tests/C/tests/src/main.fs b/tests/C/tests/src/main.fs new file mode 100644 index 0000000000..81e8194373 --- /dev/null +++ b/tests/C/tests/src/main.fs @@ -0,0 +1,17 @@ +module Main + + +[] +let main args = // args + //add2Eq4() + let a = "hello world" + ArithmeticTests.testAddition() + ArithmeticTests.testSubtraction() + ArithmeticTests.testMultiply() + ArithmeticTests.testDivide() + StringTests.testStringConcatWorks() + RunTests.testGenericMap() + RunTests.testGenericMapWithClosure() + // RunTests.testCurriedApply() + // RunTests.testGenericMap2() + 0 diff --git a/tests/C/tests/src/util.fs b/tests/C/tests/src/util.fs new file mode 100644 index 0000000000..f8c96b6a74 --- /dev/null +++ b/tests/C/tests/src/util.fs @@ -0,0 +1,7 @@ +module Util + +open Fable.Core + +[] +let assertTrue (x: bool) = + nativeOnly \ No newline at end of file