diff --git a/regression/x86only/Makefile b/regression/x86only/Makefile index 12df5a26d..1d5c64d48 100644 --- a/regression/x86only/Makefile +++ b/regression/x86only/Makefile @@ -7,7 +7,7 @@ RC=../../src/rc.opt check: $(TESTS) $(TESTS): %: %.expr - @RC_RUNTIME=../../runtime $(RC) $< && cat $@.input | ./$@ > $@.log && diff -u $@.log orig/$@.log + @RC_RUNTIME=../../runtime $(RC) -I . $< && cat $@.input | ./$@ > $@.log && diff -u $@.log orig/$@.log clean: rm -f test*.log *.s *~ $(TESTS) diff --git a/regression/x86only/orig/test005.log b/regression/x86only/orig/test005.log new file mode 100644 index 000000000..44eef781d --- /dev/null +++ b/regression/x86only/orig/test005.log @@ -0,0 +1 @@ +called with this one diff --git a/regression/x86only/test001.expr b/regression/x86only/test001.expr index 2843db667..998a9d542 100644 --- a/regression/x86only/test001.expr +++ b/regression/x86only/test001.expr @@ -1,5 +1,3 @@ -external fun printf (); - fun insert (tree, value) { case tree of Empty -> return Node (value, Empty, Empty) diff --git a/regression/x86only/test002.expr b/regression/x86only/test002.expr index a45b43f36..9f3ecd3b1 100644 --- a/regression/x86only/test002.expr +++ b/regression/x86only/test002.expr @@ -1,5 +1,3 @@ -external fun printf (); - fun collect_ints_acc (v, tail) { local i; diff --git a/regression/x86only/test003.expr b/regression/x86only/test003.expr index 507b45bd8..f6a6c05fc 100644 --- a/regression/x86only/test003.expr +++ b/regression/x86only/test003.expr @@ -1,5 +1,3 @@ -external fun printf (); - local lists = [ {}, {1, 2, 3, 4}, diff --git a/regression/x86only/test004.expr b/regression/x86only/test004.expr index bf31684d0..dd6d8f6e5 100644 --- a/regression/x86only/test004.expr +++ b/regression/x86only/test004.expr @@ -1,5 +1,3 @@ -external fun printf (); - fun hd (l) { case l of h : _ -> return h diff --git a/regression/x86only/test005.expr b/regression/x86only/test005.expr new file mode 100644 index 000000000..2efee99f5 --- /dev/null +++ b/regression/x86only/test005.expr @@ -0,0 +1,5 @@ +public fun from_test005 (s) { + printf ("called with %s\n", s) +} + +from_test005 ("this one") \ No newline at end of file diff --git a/regression/x86only/test005.input b/regression/x86only/test005.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/x86only/test005.input @@ -0,0 +1 @@ +0 diff --git a/regression/x86only/test006.expr b/regression/x86only/test006.expr new file mode 100644 index 000000000..da49c4cc3 --- /dev/null +++ b/regression/x86only/test006.expr @@ -0,0 +1,3 @@ +import test005; + +from_test005 ("that one") \ No newline at end of file diff --git a/regression/x86only/test006.input b/regression/x86only/test006.input new file mode 100644 index 000000000..573541ac9 --- /dev/null +++ b/regression/x86only/test006.input @@ -0,0 +1 @@ +0 diff --git a/runtime/Std.i b/runtime/Std.i new file mode 100644 index 000000000..0a7ba6b8a --- /dev/null +++ b/runtime/Std.i @@ -0,0 +1,3 @@ +F,printf; +F,read; +F,write; diff --git a/src/Driver.ml b/src/Driver.ml index 8bd314725..331def9f5 100644 --- a/src/Driver.ml +++ b/src/Driver.ml @@ -8,7 +8,7 @@ let parse infile = "while"; "do"; "od"; "repeat"; "until"; "for"; - "fun"; "local"; "public"; "external"; "return"; + "fun"; "local"; "public"; "external"; "return"; "import"; "length"; "string"; "case"; "of"; "esac"; "when"; @@ -30,7 +30,7 @@ let parse infile = ] s end ) - (ostap (!(Language.parse Language.Infix.default) -EOF)) + (ostap (p:!(Language.parse Language.Infix.default) -EOF)) exception Commandline_error of string @@ -40,7 +40,7 @@ class options args = object (self) val i = ref 1 val infile = ref (None : string option) - val paths = ref ([] : string list) + val paths = ref [try Sys.getenv "RC_RUNTIME" with _ -> "../runtime"] val mode = ref (`Default : [`Default | `Eval | `SM | `Compile ]) val help = ref false initializer @@ -89,18 +89,12 @@ class options args = let main = (* try*) let cmd = new options Sys.argv in - - (*let interpret = Sys.argv.(1) = "-i" in - let stack = Sys.argv.(1) = "-s" in - let to_compile = not (interpret || stack) in - let infile = Sys.argv.(if not to_compile then 2 else 1) in - *) match (try parse cmd#get_infile with Language.Semantic_error msg -> `Fail msg) with | `Ok prog -> (match cmd#get_mode with | `Default | `Compile -> - ignore @@ X86.build cmd prog - | _ -> + ignore @@ X86.build cmd prog + | _ -> (* Printf.printf "Program:\n%s\n" (GT.show(Language.Expr.t) prog);*) (*Format.printf "Program\n%s\n%!" (HTML.toHTML ((GT.html(Language.Expr.t)) prog));*) let rec read acc = @@ -109,14 +103,14 @@ let main = Printf.printf "> "; read (acc @ [r]) with End_of_file -> acc - in + in let input = read [] in let output = if cmd#get_mode = `Eval then Language.eval prog input - else SM.run (SM.compile prog) input + else SM.run (SM.compile cmd prog) input in - List.iter (fun i -> Printf.printf "%d\n" i) output + List.iter (fun i -> Printf.printf "%d\n" i) output ) | `Fail er -> Printf.eprintf "Error: %s\n" er (* with Invalid_argument _ -> diff --git a/src/Language.ml b/src/Language.ml index 16f2113f3..a6a4abb65 100644 --- a/src/Language.ml +++ b/src/Language.ml @@ -837,10 +837,68 @@ module Definition = end -(* The top-level definitions *) +module Interface = + struct + + (* Generates an interface file. *) + let gen (imps, p) = + let buf = Buffer.create 256 in + let append str = Buffer.add_string buf str in + List.iter (fun i -> append "I,"; append i; append ";\n") imps; + (match p with + | Expr.Scope (decls, _) -> + List.iter + (function + | (name, (`Public, item)) | (name, (`PublicExtern, item)) -> + (match item with + | `Fun _ -> append "F,"; append name; append ";\n" + | `Variable _ -> append "V,"; append name; append ";\n" + ) + | _ -> () + ) + decls; + | _ -> ()); + Buffer.contents buf + + (* Read an interface file *) + let read fname = + let ostap ( + funspec: "F" "," i:IDENT ";" {`Fun i}; + varspec: "V" "," i:IDENT ";" {`Variable i}; + import : "I" "," i:IDENT ";" {`Import i}; + interface: (funspec | varspec | import)* + ) + in + try + let s = Util.read fname in + (match Util.parse (object + inherit Matcher.t s + inherit Util.Lexers.ident [] s + inherit Util.Lexers.skip [Matcher.Skip.whitespaces " \t\n"] s + end) + (ostap (interface -EOF)) + with + | `Ok intfs -> Some intfs + | `Fail er -> invalid_arg (Printf.sprintf "malformed interface file '%s': %s" fname er) + ) + with Sys_error _ -> None -(* The top-level syntax category is a pair of definition list and statement (program body) *) -type t = Definition.t list * Expr.t + let find import paths = + let rec inner = function + | [] -> None + | p::paths -> + (match read (Filename.concat p (import ^ ".i")) with + | None -> inner paths + | Some i -> Some (p, i) + ) + in + match inner paths with + | Some (path, intfs) -> path, intfs + | None -> invalid_arg (Printf.sprintf "could not find an interface file for import '%s'" import) + + end + +(* The top-level definitions *) (* Top-level evaluator @@ -848,15 +906,16 @@ type t = Definition.t list * Expr.t Takes a program and its input stream, and returns the output stream *) -let eval expr i = +let eval (_, expr) i = let _, _, o, _ = Expr.eval (State.empty, i, [], []) Skip expr in o (* Top-level parser *) ostap ( + imports: is:(%"import" !(Util.list (ostap (LIDENT))) -";")* {List.flatten is}; parse[infix]: - <(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? { - Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e) + is:imports <(d, infix')> : definitions[infix] expr:!(Expr.parse definitions infix' Expr.Void)? { + is, Expr.Scope (d, match expr with None -> Expr.Skip | Some e -> e) }; definitions[infix]: <(def, infix')> : !(Definition.parse infix Expr.basic definitions) <(defs, infix'')> : definitions[infix'] { diff --git a/src/SM.ml b/src/SM.ml index f51f3fc57..e6d1b8b0e 100644 --- a/src/SM.ml +++ b/src/SM.ml @@ -31,7 +31,7 @@ open Language (* checks the tag and size of array *) | ARRAY of int (* checks various patterns *) | PATT of patt (* external definition *) | EXTERN of string -(* public definition *) | PUBLIC of string +(* public definition *) | PUBLIC of string with show (* The type for the stack machine program *) @@ -333,7 +333,7 @@ let rec propagate_acc (Item (p, fds, up) as item) name = }}, fds, up'), Value.Access index | other -> item, other -class env = +class env cmd imports = object (self : 'self) val label_index = 0 val scope_index = 0 @@ -341,7 +341,26 @@ object (self : 'self) val scope = init_scope State.I val fundefs = Top [] val decls = [] - + + method private import_imports = + let paths = cmd#get_include_paths in + let env = List.fold_left + (fun env import -> + let _, intfs = Interface.find import paths in + List.fold_left + (fun env -> function + | `Variable name -> env#add_name name `Extern true + | `Fun name -> env#add_fun_name name `Extern + | _ -> env + ) + env + intfs + ) + self + ("Std" :: imports) + in + env + method global_scope = scope_index = 0 method get_label = (label @@ string_of_int label_index), {< label_index = label_index + 1 >} @@ -360,28 +379,25 @@ object (self : 'self) ) @@ List.filter (function (_, `Local) -> false | _ -> true) decls - method push_scope = {< - scope_index = scope_index + 1; - scope = { - scope with - st = match scope.st with - | State.I -> - State.G (Builtin.names, - List.fold_left - (fun s (name, value) -> - let name' = - match name.[0] with - | '.' -> name - | _ -> "L" ^ name - in - State.bind name (Value.Fun name') s) - State.undefined - (Builtin.bindings ())) - | _ -> - State.L ([], State.undefined, scope.st) - } - >} - + method push_scope = + match scope.st with + | State.I -> + {< + scope_index = scope_index + 1; + scope = { + scope with + st = State.G ([], State.undefined) + } + >} # import_imports + + | _ -> + {< scope_index = scope_index + 1; + scope = { + scope with + st = State.L ([], State.undefined, scope.st) + } + >} + method pop_scope = match scope.st with | State.I -> {< scope = {scope with st = State.I} >} @@ -446,7 +462,7 @@ object (self : 'self) | State.I -> invalid_arg "uninitialized scope" | State.G (names, s) -> - State.G (check_name_and_add names name mut, State.bind name (Value.Global name) s) + State.G ((match m with `Extern | `PublicExtern -> names | _ -> check_name_and_add names name mut), State.bind name (Value.Global name) s) | State.L (names, s, p) -> self#check_scope m name; State.L (check_name_and_add names name mut, State.bind name (Value.Local scope.local_index) s, p) @@ -466,7 +482,7 @@ object (self : 'self) | State.I -> invalid_arg "uninitialized scope" | State.G (names, s) -> - State.G (check_name_and_add names name false, State.bind name (Value.Fun name') s) + State.G ((match m with `Extern | `PublicExtern -> names | _ -> check_name_and_add names name false), State.bind name (Value.Fun name') s) | State.L (names, s, p) -> self#check_scope m name; State.L (check_name_and_add names name false, State.bind name (Value.Fun name') s, p) @@ -514,7 +530,7 @@ object (self : 'self) end -let compile p = +let compile cmd (imports, p) = let rec pattern env lfalse = function | Pattern.Wildcard -> env, false, [DROP] | Pattern.Named (_, p) -> pattern env lfalse p @@ -736,7 +752,7 @@ let compile p = let env, code = compile_fundef env def in compile_fundefs (acc @ code) env in - let env = new env in + let env = new env cmd imports in let lend, env = env#get_label in let env, flag, code = compile_expr lend env p in let code = if flag then code @ [LABEL lend] else code in diff --git a/src/X86.ml b/src/X86.ml index 6b82b3cbb..0d44a3788 100644 --- a/src/X86.ml +++ b/src/X86.ml @@ -649,8 +649,8 @@ class env prg = (* Generates an assembler text for a program: first compiles the program into the stack code, then generates x86 assember code, then prints the assembler file *) -let genasm prog = - let sm = SM.compile prog in +let genasm cmd prog = + let sm = SM.compile cmd prog in let env, code = compile (new env sm) sm in let gc_start, gc_end = "__gc_data_start", "__gc_data_end" in let globals = @@ -671,14 +671,38 @@ let genasm prog = (* Builds a program: generates the assembler file and compiles it with the gcc toolchain *) let build cmd prog = + let find_objects imports paths = + let module S = Set.Make (String) in + let rec iterate acc s = function + | [] -> acc + | import::imports -> + if S.mem import s + then iterate acc s imports + else + let path, intfs = Interface.find import paths in + iterate + ((import ^ ".o") :: acc) + (S.add import s) + ((List.map (function `Import name -> name | _ -> invalid_arg "must not happen") @@ + List.filter (function `Import _ -> true | _ -> false) intfs) @ + imports) + in + iterate [] S.empty imports + in let name = Filename.chop_suffix cmd#get_infile ".expr" in let outf = open_out (Printf.sprintf "%s.s" name) in - Printf.fprintf outf "%s" (genasm prog); + Printf.fprintf outf "%s" (genasm cmd prog); close_out outf; + let outf = open_out (Printf.sprintf "%s.i" name) in + Printf.fprintf outf "%s" (Interface.gen prog); + close_out outf; let inc = try Sys.getenv "RC_RUNTIME" with _ -> "../runtime" in match cmd#get_mode with | `Default -> - Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s/runtime.a" name name inc) + let objs = find_objects (fst prog) cmd#get_include_paths in + let buf = Buffer.create 255 in + List.iter (fun o -> Buffer.add_string buf o; Buffer.add_string buf " ") objs; + Sys.command (Printf.sprintf "gcc -g -m32 -o %s %s.s %s %s/runtime.a" name name (Buffer.contents buf) inc) | `Compile -> Sys.command (Printf.sprintf "gcc -g -m32 -c %s.s" name) | _ -> invalid_arg "must not happen"