diff --git a/.gitignore b/.gitignore index 4256db2..8337bb2 100644 --- a/.gitignore +++ b/.gitignore @@ -10,3 +10,4 @@ test.out a.out *.log *.tar.gz +src/.merlin diff --git a/Makefile b/Makefile index 6fe6817..fef700c 100644 --- a/Makefile +++ b/Makefile @@ -1,30 +1,9 @@ - -MODE=debug -# debug or release - VERSION := $(strip $(shell scripts/getcfgvar.sh version)) -DEBUG_LIBS=nums.cmxa -RELEASE_LIBS=nums.cmxa - -DEBUG_FLAGS=-inline 0 -g -RELEASE_FLAGS=-inline 40 -noassert -unsafe -nodynlink -ccopt -O9 - -SPACE := -SPACE += -COMMA = , -DIRS=$(shell scripts/lsdirs.sh src) -IDIRS=$(subst $(SPACE),$(COMMA),$(DIRS)) - -all: $(MODE) - -debug: - ocamlbuild -pp 'm4 -P' -ocamlopt "ocamlopt.opt -pp 'm4 -P' -S $(DEBUG_FLAGS) $(DEBUG_LIBS)" -Is $(IDIRS) hcpl.native - cp hcpl.native hcpl - -release: - ocamlbuild -pp 'm4 -P' -ocamlopt "ocamlopt.opt -pp 'm4 -P' -S $(RELEASE_FLAGS) $(RELEASE_LIBS)" -Is $(IDIRS) hcpl.native - cp hcpl.native hcpl +all: + dune build + cp _build/default/src/hcpl.exe hcpl + chmod u+w hcpl package: clean -scripts/rmbackups.sh @@ -67,7 +46,7 @@ benchmark: release scripts/run-benchmarks.sh clean: - ocamlbuild -clean + dune clean -rm hcpl -rm *.out -rm *.log diff --git a/README b/README index 31402b3..14df7c0 100644 --- a/README +++ b/README @@ -1,4 +1,3 @@ - What do you need to compile and use HCPL? * OCaml 3.12. @@ -19,7 +18,7 @@ To run tests type: To install HCPL type: * make configure * make - * sudo make install + * make install During installation you will be asked for the data directory. In this directory the examples, the standard library and other data files of diff --git a/dune-project b/dune-project new file mode 100644 index 0000000..e5d2feb --- /dev/null +++ b/dune-project @@ -0,0 +1,2 @@ +(lang dune 2.5) +(name hcpl) diff --git a/scripts/install.sh b/scripts/install.sh index 69278ed..520e1e5 100755 --- a/scripts/install.sh +++ b/scripts/install.sh @@ -9,7 +9,7 @@ cp -r examples/ $data_dir/examples cp -r tests/ $data_dir/tests cp README $data_dir/README mkdir -p $data_dir/bin -cp hcpl $data_dir/bin/ipl +cp hcpl $data_dir/bin/hcpl cp uninstall.sh $data_dir/bin/uninstall.sh ln -s $data_dir/bin/hcpl $bin_dir/hcpl diff --git a/src/builtins/core_builtins.ml b/src/builtins/core_builtins.ml index d8e86d6..8d03abf 100644 --- a/src/builtins/core_builtins.ml +++ b/src/builtins/core_builtins.ml @@ -4,7 +4,6 @@ *) open Node -open Big_int let is_number lst = match lst with @@ -46,10 +45,10 @@ let module_hash = Symbol.Hash.create 16 let load_module lst = match lst with - | x :: init_node :: y :: env -> + | x :: init_node :: y :: _ -> begin match x, y with - | bfrm, Sym(sym) -> + | _, Sym(sym) -> begin try Symbol.Hash.find module_hash sym diff --git a/src/builtins/list_builtins.ml b/src/builtins/list_builtins.ml index cd31d33..ecd8045 100644 --- a/src/builtins/list_builtins.ml +++ b/src/builtins/list_builtins.ml @@ -233,7 +233,7 @@ let rec do_rev_split_n f n lst acc acc2 = let do_split_n f n lst = match lst with - | Cons(h, t) -> do_rev2 (do_rev_split_n f n lst Nil Nil) Nil + | Cons(_, _) -> do_rev2 (do_rev_split_n f n lst Nil Nil) Nil | _ -> Cons(Nil, Nil) (* quoted variants *) diff --git a/src/core/config.ml b/src/core/config.ml index 27f7ce7..50a85a4 100644 --- a/src/core/config.ml +++ b/src/core/config.ml @@ -7,7 +7,9 @@ let version = "git-master" let data_dir = "." +[@@@warning "-32"] let bin_dir = "." +[@@@warning "+32"] let dir_sep () = "/" diff --git a/src/core/error.ml b/src/core/error.ml index d0fc19d..905a6c9 100644 --- a/src/core/error.ml +++ b/src/core/error.ml @@ -8,7 +8,7 @@ open Lexing exception RuntimeError of Node.t (* 'rec' to prevent inlining *) -let rec runtime_error msg = raise (RuntimeError(Node.String(msg))) +let [@warning "-39"]rec runtime_error msg = raise (RuntimeError(Node.String(msg))) let err_count = Array.make 4 0 diff --git a/src/core/node.ml b/src/core/node.ml index ae79660..2f9d5cf 100644 --- a/src/core/node.ml +++ b/src/core/node.ml @@ -280,13 +280,13 @@ let get_name node = Attrs.get_name (get_attrs node) let get_pos node = Attrs.get_pos (get_attrs node) -let get_attr node name = Attrs.get_attr (get_attrs node) +let get_attr node _ = Attrs.get_attr (get_attrs node) let is_special node = Attrs.is_special (get_attrs node) let rec is_module_closed node = match node with - | Appl(Appl(f, x, _), y, _) when f == progn -> is_module_closed y + | Appl(Appl(f, _, _), y, _) when f == progn -> is_module_closed y | Appl(f, x, _) -> if f == id then is_module_closed x @@ -401,7 +401,7 @@ let to_string node = in let rec is_list node = match node with - | Cons(x, y) -> is_list y + | Cons(_, y) -> is_list y | Nil -> true | _ -> false in diff --git a/src/dune b/src/dune new file mode 100644 index 0000000..ba0f001 --- /dev/null +++ b/src/dune @@ -0,0 +1,8 @@ +(executable + (name hcpl) + (libraries num) + (modes native) + (ocamlopt_flags -inline 40 -noassert -unsafe -nodynlink -ccopt -O9) + (preprocess (action (run m4 -P %{input-file})))) + +(include_subdirs unqualified) diff --git a/src/eval/bignum.ml b/src/eval/bignum.ml index bd2d74e..e7e7c7d 100644 --- a/src/eval/bignum.ml +++ b/src/eval/bignum.ml @@ -57,7 +57,7 @@ let mul_fits x y = msb x + msb y <= smallint_bits (* "rec" to prevent inlining *) -let rec do_gt x y = +let [@warning "-39"]rec do_gt x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -88,7 +88,7 @@ let gt x y = else do_gt x y -let rec do_ge x y = +let [@warning "-39"]rec do_ge x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -119,7 +119,7 @@ let ge x y = else do_ge x y -let rec do_add x y = +let [@warning "-39"]rec do_add x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -146,7 +146,7 @@ let add x y = else do_add x y -let rec do_sub x y = +let [@warning "-39"]rec do_sub x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -173,7 +173,7 @@ let sub x y = else do_sub x y -let rec do_mul x y = +let [@warning "-39"]rec do_mul x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -208,7 +208,7 @@ let mul x y = else do_mul x y -let rec do_idiv x y = +let [@warning "-39"]rec do_idiv x y = if is_smallint x then begin assert (not (is_smallint y)); @@ -235,7 +235,7 @@ let idiv x y = else do_idiv x y -let rec do_modulo x y = +let [@warning "-39"]rec do_modulo x y = if is_smallint x then begin assert (not (is_smallint y)); diff --git a/src/eval/env.ml b/src/eval/env.ml index 556b19f..a10d37a 100644 --- a/src/eval/env.ml +++ b/src/eval/env.ml @@ -43,7 +43,7 @@ let rec pop_n env n = begin assert (env != []); match env with - | h :: t -> pop_n t (n - 1) + | _ :: t -> pop_n t (n - 1) | [] -> assert (env <> []); [] end else diff --git a/src/eval/eval.ml b/src/eval/eval.ml index 8fd67f3..27ac489 100644 --- a/src/eval/eval.ml +++ b/src/eval/eval.ml @@ -81,13 +81,6 @@ m4_define(`ACCESS_VAR', ` in do_eval x $1 $2 (* keep in mind that the values in environments are closed *) - (* match x with - | Closure(a, env2, env2_len) -> - do_eval a env2 env2_len - | Delayed(r) -> - do_eval_delayed r - | _ -> (*assert (is_immed x || (match x with Lambda(_, 0, _, _, _) -> true | _ -> false));*) x *) - (* TODO: this need not be true, e.g.: let x = hd 3; This should be fixed!!! *) end ') @@ -133,9 +126,7 @@ let check_limit times_entered = else true -let rec do_eval_delayed r = - EVAL_DELAYED(r) -and do_eval node env env_len = +let rec do_eval node env env_len = (* Debug.print ("do_eval " ^ Utils.list_to_string Node.to_string env ^ ": " ^ Node.to_string node); *) match node with | Appl(x, y, attrs) -> diff --git a/src/eval/match.ml b/src/eval/match.ml index be21722..1b6a2de 100644 --- a/src/eval/match.ml +++ b/src/eval/match.ml @@ -10,9 +10,9 @@ exception Unknown type match_quoted_mode_t = ModeMatch | ModeEq | ModeQuotedEq -let rec check_tokens_eq lst1 lst2 = +let [@warning "-39"]rec check_tokens_eq lst1 lst2 = match lst1, lst2 with - | ((tok1, _) :: t1), ((tok2, _) :: t2) when Token.eq tok1 tok2 -> true + | ((tok1, _) :: _), ((tok2, _) :: _) when Token.eq tok1 tok2 -> true | _ -> false let rec do_match_quoted node pat penv penv_len nenv nenv_len acc (mode : match_quoted_mode_t) = @@ -131,10 +131,10 @@ let rec do_match_quoted node pat penv penv_len nenv nenv_len acc (mode : match_q | _ -> raise Exit end - | Lambda(body, frame, _, _, attrs1) -> + | Lambda(body, frame, _, _, _) -> begin match node with - | Lambda(body2, frame2, _, _, attrs2) -> + | Lambda(body2, frame2, _, _, _) -> if frame > penv_len || frame2 > nenv_len then begin raise Exit diff --git a/src/eval/quote.ml b/src/eval/quote.ml index e1a2d69..5caf9ad 100644 --- a/src/eval/quote.ml +++ b/src/eval/quote.ml @@ -263,7 +263,7 @@ let subst node node1 node2 = Error.runtime_error "arguments of subst should be quoted" let do_lift node f = - let rec aux node = + let [@warning "-39"]rec aux node = Traversal.transform (fun x _ _ frames_num -> if f x then diff --git a/src/eval/traversal.ml b/src/eval/traversal.ml index 5254702..55e3939 100644 --- a/src/eval/traversal.ml +++ b/src/eval/traversal.ml @@ -238,7 +238,7 @@ let traverse f node acc = end else f node acc - | Lambda(body, frame, call_type, times_entered, attrs) -> + | Lambda(body, frame, _, _, _) -> begin assert (frame <= env_len); let env2 = Env.pop_n env (env_len - frame) @@ -268,7 +268,7 @@ let traverse f node acc = end | Closure(x, env, env_len) -> Skip(aux x env env_len acc) - | LambdaClosure(body, env, env_len, call_type, times_entered, attrs) -> + | LambdaClosure(body, env, env_len, _, _, _) -> Skip(aux body (Dummy :: env) (env_len + 1) acc) | _ -> f node acc) diff --git a/src/parsing/dune b/src/parsing/dune new file mode 100644 index 0000000..8a660b9 --- /dev/null +++ b/src/parsing/dune @@ -0,0 +1 @@ +(ocamllex scanner) diff --git a/src/parsing/loader.ml b/src/parsing/loader.ml index eca0914..d7f4a83 100644 --- a/src/parsing/loader.ml +++ b/src/parsing/loader.ml @@ -7,14 +7,14 @@ type identtab_t = Node.t Symbol.Map.t let load_module name parse = assert (name <> ""); - let name2 = String.copy name + let name2 = Bytes.of_string name in - name2.[0] <- Char.lowercase (name2.[0]); + Bytes.set name2 0 (Char.lowercase_ascii (Bytes.get name2 0)); let rec loop lst = match lst with | h :: t -> begin - let path = h ^ Config.dir_sep () ^ name2 ^ ".hcpl" + let path = h ^ Config.dir_sep () ^ (Bytes.to_string name2) ^ ".hcpl" in try let lexbuf = Lexing.from_channel (open_in path) diff --git a/src/parsing/parser.ml b/src/parsing/parser.ml index 0263857..7e63752 100644 --- a/src/parsing/parser.ml +++ b/src/parsing/parser.ml @@ -50,7 +50,6 @@ type sexp_t = | Program of Node.t | MatchBranch of Node.t * Node.t * int (* (cond, body, args_num) *) | Ident of Symbol.t - | Bool of bool | CallType of Node.call_t | Number of Big_int.big_int | Num of int @@ -66,7 +65,6 @@ let rec sexp_to_string sexp = | Program(node) -> "Program(" ^ Node.to_string node ^ ")" | MatchBranch(cond, body, n) -> "Program(" ^ Node.to_string cond ^ "," ^ Node.to_string body ^ ", " ^ string_of_int n ^ ")" | Ident(sym) -> "Ident(" ^ Symbol.to_string sym ^ ")" - | Bool(b) -> "Bool(" ^ (if b then "true" else "false") ^ ")" | CallType(ct) -> "CallType(" ^ Node.call_type_to_string ct ^ ")" | Number(num) -> "Number(" ^ Big_int.string_of_big_int num ^ ")" | Num(num) -> "Num(" ^ string_of_int num ^ ")" @@ -85,11 +83,6 @@ let create_attrs scope strm = module State = struct type t = sexp_t list * Node.Attrs.t * TokenStream.t * Scope.t - - let get_lst ((x, _, _, _) : t) = x - let get_attrs ((_, x, _, _) : t) = x - let get_strm ((_, _, x, _) : t) = x - let get_scope ((_, _, _, x) : t) = x end type parser_cont_t = State.t -> State.t @@ -208,7 +201,7 @@ let token (token : Token.t) = (fun () -> cont state2))) let peek (token : Token.t) = - fun () ((lst, attrs, strm, scope) as state) (cont : parser_cont_t) -> + fun () ((_, _, strm, scope) as state) (cont : parser_cont_t) -> if Token.eq (Scope.strm_token scope strm) token then cont state else @@ -216,13 +209,6 @@ let peek (token : Token.t) = "syntax error", (fun () -> cont state))) -let warn msg = - fun () ((_, _, strm, scope) as state) (cont : parser_cont_t) -> - begin - Error.warn (Some(Scope.strm_position scope strm)) msg; - cont state - end - let symbol sym = token (Token.Symbol(sym)) let keyword sym = token (Token.Keyword(sym)) @@ -274,7 +260,7 @@ let skip_until (tokens : Token.t list) = let std_error_resume state cont = (fun () -> skip_until [Token.Sep; Token.LetEager; Token.LetLazy; Token.LetCBN] () state cont) -let eof () ((lst, attrs, strm, scope) as state) cont = +let eof () ((_, _, strm, scope) as state) cont = if Scope.is_strm_empty scope strm then cont state else @@ -282,7 +268,7 @@ let eof () ((lst, attrs, strm, scope) as state) cont = "syntax error", std_error_resume state cont)) -let check pred error_msg () ((lst, attrs, strm, scope) as state) cont = +let check pred error_msg () ((_, _, strm, scope) as state) cont = if pred scope then cont state else @@ -298,7 +284,7 @@ let maybe r = r ^|| empty let optional r = maybe r >> collect let fail msg lst0 = - (fun () ((lst, attrs, strm, scope) as state) cont -> + (fun () ((_, _, strm, scope) as state) cont -> raise (ParseFailure(Some(Scope.strm_position scope strm), msg, (fun () -> skip () state @@ -357,12 +343,6 @@ let enter_match (r : parser_rule_t) = (fun (lst2, attrs2, strm2, _) -> cont (lst2, attrs2, strm2, scope)) -let save_scope (r : parser_rule_t) = - fun () (lst, attrs, strm, scope) cont -> - r () (lst, attrs, strm, scope) - (fun (lst2, attrs2, strm2, _) -> - cont (lst2, attrs2, strm2, scope)) - let new_keyword sym (r : parser_rule_t) = fun () (lst, attrs, strm, scope) cont -> r () (lst, attrs, strm, Scope.add_keyword scope sym) @@ -614,7 +594,7 @@ m4_changequote([`],[']) | [String(str)] -> Program(Node.String(str)) | _ -> assert false) - and repl_eval () ((lst, attrs, _, scope) as state) cont = + and repl_eval () ((lst, _, _, scope) as state) cont = if is_repl_mode && Scope.nesting scope = 0 then begin check_fwd_decls (); @@ -630,7 +610,7 @@ m4_changequote([`],[']) else cont state - and repl_decl () ((lst, attrs, _, scope) as state) cont = + and repl_decl () ((lst, _, _, scope) as state) cont = if is_repl_mode && Scope.nesting scope = 0 then begin check_fwd_decls (); @@ -703,7 +683,7 @@ m4_changequote([`],[']) | _ -> assert false) and import_idents f = - (fun sym module_node identtab syntax attrs scope -> + (fun sym module_node identtab _ attrs scope -> Symbol.Map.fold (fun k node scope -> let node2 = @@ -724,7 +704,7 @@ m4_changequote([`],[']) scope ) - and add_syntax sym module_node identtab syntax attrs scope = + and add_syntax _ _ _ syntax _ scope = Scope.add_syntax scope syntax in @@ -877,7 +857,7 @@ m4_changequote([`],[']) aux2 Token.LeftParen Token.RightParen | Token.LeftParenCurl -> aux2 Token.LeftParenCurl Token.RightParenCurl - | Token.Symbol(sym) -> + | Token.Symbol(_) -> let strm3 = Scope.strm_next scope strm2 in (((tok2, pos2) :: (tok, pos) :: acc), strm3) @@ -910,7 +890,7 @@ m4_changequote([`],[']) let acc2 = (tok2, pos2) :: (tok, pos) :: acc in match tok2 with - | Token.Symbol(sym) -> + | Token.Symbol(_) -> begin let strm3 = Scope.strm_next scope strm2 in @@ -1157,7 +1137,7 @@ m4_changequote([`],[']) >> (fun lst attrs scope -> match lst with - | [CallType(ct); Ident(sym); Program(value); Program(body)] -> + | [CallType(ct); Ident(_); Program(value); Program(body)] -> if Node.is_immediate value then Program(Node.optimize body) else @@ -1192,7 +1172,7 @@ m4_changequote([`],[']) progn ) >> - (fun lst attrs scope -> + (fun lst _ scope -> match lst with | [Num(i); Program(value); Program(value2)] -> Program(Node.DynDef(Node.Var(Scope.frame scope), i, Node.optimize value, Node.optimize value2)) @@ -1296,7 +1276,7 @@ m4_changequote([`],[']) symbol sym_unary +> return (Arity 1) ^|| maybe (symbol sym_prio) ++ symbol sym_after ++ name +> - (fun lst attrs scope -> + (fun lst _ _ -> match lst with | [Ident(sym)] -> if Symbol.eq sym sym_appl then @@ -1307,7 +1287,7 @@ m4_changequote([`],[']) ^|| maybe (symbol sym_prio) ++ symbol sym_before ++ name +> - (fun lst attrs scope -> + (fun lst _ _ -> match lst with | [Ident(sym)] -> if Symbol.eq sym sym_appl then @@ -1326,7 +1306,7 @@ m4_changequote([`],[']) ^|| symbol sym_prio ++ name +> - (fun lst attrs scope -> + (fun lst _ _ -> match lst with | [Ident(sym)] -> if Symbol.eq sym sym_appl then @@ -1363,7 +1343,7 @@ m4_changequote([`],[']) (discard (symbol sym_block +! name ++ name ++ change_scope - (fun lst attrs scope -> + (fun lst _ scope -> match lst with | [Ident(beg_sym); Ident(end_sym)] -> Scope.add_block scope beg_sym end_sym @@ -1374,7 +1354,7 @@ m4_changequote([`],[']) (discard (symbol sym_macrosep +! name ++ change_scope - (fun lst attrs scope -> + (fun lst _ scope -> match lst with | [Ident(sym)] -> Scope.add_macrosep scope sym @@ -1473,7 +1453,7 @@ m4_changequote([`],[']) in progn () ([], create_attrs scope strm, strm, Scope.enter_module (Scope.push scope) (unique_module_id ())) - (fun (lst2, attrs2, strm2, scope2) -> + (fun (lst2, _, strm2, scope2) -> let node = get_singleton_node lst2 in let m = @@ -1686,7 +1666,7 @@ m4_changequote([`],[']) >> (fun lst attrs scope -> match lst with - | [CallType(ct); Ident(sym); Program(body)] -> + | [CallType(ct); Ident(_); Program(body)] -> Program(Quote.correct_lambda (Node.Lambda(Node.optimize body, Scope.frame scope + 1, ct, ref 0, attrs))) | _ -> assert false) end @@ -1728,7 +1708,7 @@ m4_changequote([`],[']) begin (symbol sym_quote ^|| symbol sym_quote2) ++ term >> - (fun lst attrs scope -> + (fun lst _ _ -> match lst with | [Program(value)] -> begin @@ -1849,7 +1829,7 @@ m4_changequote([`],[']) keyword sym_match +! new_keyword sym_with (catch_errors expr) ++ symbol sym_with ++ new_ident_scope (maybe (symbol sym_match_sep) ++ match_branches) >> - (fun lst attrs scope -> + (fun lst _ _ -> match lst with | Program(value) :: lst2 -> Program(Node.BMatch(value, mkbranches lst2)) @@ -1868,7 +1848,7 @@ m4_changequote([`],[']) new_ident_scope (enter_match (new_keyword sym_arrow (new_keyword sym_when (catch_errors expr)) ++ - (fun () ((lst, attrs, strm, scope) as state) cont -> + (fun () ((_, _, strm, scope) as state) cont -> let rec mkparse placeholders = match placeholders with | h :: t -> @@ -1896,7 +1876,7 @@ m4_changequote([`],[']) let n = List.length placeholders in (mkparse placeholders >> - (fun lst attrs _ -> + (fun lst _ _ -> match lst with | [Program(cond); Program(body)] -> MatchBranch(Node.optimize cond, Node.optimize body, n) | _ -> assert false)) @@ -1932,7 +1912,7 @@ m4_changequote([`],[']) begin lparen_sqr +! new_scope (maybe list_elems) ++ rparen_sqr >> - (fun lst _ scope -> + (fun lst _ _ -> Program(List.fold_right (fun x y -> match x with @@ -1977,7 +1957,7 @@ m4_changequote([`],[']) recursive begin ident - (fun sym pos _ -> + (fun _ _ _ -> (Node.Proxy(ref Node.Nil))) end diff --git a/src/parsing/scope.ml b/src/parsing/scope.ml index 9d532a3..1042207 100644 --- a/src/parsing/scope.ml +++ b/src/parsing/scope.ml @@ -151,7 +151,7 @@ let enter_module scope (sym : Symbol.t) = let leave_module scope = match scope.modules with - | h :: t -> { scope with modules = t; module_mode = false } + | _ :: t -> { scope with modules = t; module_mode = false } | [] -> scope let current_module scope = @@ -267,7 +267,7 @@ let get_block_end scope beg_sym = let is_block_end scope end_sym = try Symbol.Map.fold - (fun k sym acc -> + (fun _ sym acc -> if Symbol.eq sym end_sym then raise Exit else