diff --git a/Makefile b/Makefile index ccf6e46..1f1ce27 100644 --- a/Makefile +++ b/Makefile @@ -27,8 +27,14 @@ examples: dune exec ./main.exe -- ./examples/test_multi.bs dune exec ./main.exe -- ./examples/test_primitives.bs dune exec ./main.exe -- ./examples/test_scoping.bs + dune exec ./main.exe -- ./examples/test_my_lib.bs .PHONY: examples clean: @dune clean .PHONY: clean + +embed: + ocaml-embed-file -output embed ./primitives.bs + dune fmt >/dev/null 2>&1 || true +.PHONY: embed diff --git a/ast.ml b/ast.ml index 71f3f5b..7e8e6db 100644 --- a/ast.ml +++ b/ast.ml @@ -4,6 +4,7 @@ type expr = | Expr_unit | Expr_bool of bool | Expr_int of int + | Expr_string of string | Expr_id of id | Expr_define of id * expr | Expr_if of expr * expr * expr @@ -16,6 +17,7 @@ let rec ast_of_sexpr sx = | S.Atom_unit -> Expr_unit | S.Atom_bool b -> Expr_bool b | S.Atom_int i -> Expr_int i + | S.Atom_string s -> Expr_string s | S.Atom_id id -> Expr_id id in let ast_of_define = function @@ -76,6 +78,7 @@ let string_of_ast ast = | Expr_unit -> sprintf "%sUNIT" (spaces indent) | Expr_bool b -> sprintf "%sBOOL[ %b ]" (spaces indent) b | Expr_int i -> sprintf "%sINT[ %d ]" (spaces indent) i + | Expr_string s -> sprintf "%sSTRING[ %S ]" (spaces indent) s | Expr_id id -> sprintf "%sID[ %s ]" (spaces indent) id | Expr_define (id, e) -> sprintf "%sDEFINE[%s\n%s ]" (spaces indent) id (iter e (indent + 2)) diff --git a/ast.mli b/ast.mli index 39b978c..8efbbd0 100644 --- a/ast.mli +++ b/ast.mli @@ -6,6 +6,7 @@ type expr = | Expr_unit | Expr_bool of bool | Expr_int of int + | Expr_string of string | Expr_id of id | Expr_define of id * expr | Expr_if of expr * expr * expr diff --git a/dune b/dune index 8f9edc0..b73515b 100644 --- a/dune +++ b/dune @@ -5,7 +5,7 @@ (library (name bogoscheme) - (modules ast sexpr parser lexer env eval primitives)) + (modules ast sexpr parser lexer env eval primitives embed)) (executable (name main) diff --git a/embed.ml b/embed.ml new file mode 100644 index 0000000..e152c39 --- /dev/null +++ b/embed.ml @@ -0,0 +1,32 @@ +let primitives_dot_bs = + "(define not\n\ + \ (lambda (b)\n\ + \ (if b\n\ + \ #f\n\ + \ #t)))\n\n\ + (define zero?\n\ + \ (lambda (x)\n\ + \ (if (= x 0)\n\ + \ #t\n\ + \ #f)))\n\n\ + (define positive?\n\ + \ (lambda (x)\n\ + \ (if (> x 0)\n\ + \ #t\n\ + \ #f)))\n\n\ + (define negative?\n\ + \ (lambda (x)\n\ + \ (if (< x 0)\n\ + \ #t\n\ + \ #f)))\n\n\ + (define min\n\ + \ (lambda (x y)\n\ + \ (if (< x y)\n\ + \ x\n\ + \ y)))\n\n\ + (define max\n\ + \ (lambda (x y)\n\ + \ (if (> x y)\n\ + \ x\n\ + \ y)))\n" +;; diff --git a/embed.mli b/embed.mli new file mode 100644 index 0000000..5240fc9 --- /dev/null +++ b/embed.mli @@ -0,0 +1 @@ +val primitives_dot_bs : string diff --git a/env.ml b/env.ml index a36be3f..a3f839b 100644 --- a/env.ml +++ b/env.ml @@ -6,7 +6,8 @@ type value = | Val_unit | Val_bool of bool | Val_int of int - | Val_prim of (value list -> value) (* primitive functions *) + | Val_string of string + | Val_prim of (env -> value list -> value) (* primitive functions *) | Val_lambda of env * id list * Ast.expr list and env = @@ -22,6 +23,7 @@ let string_of_value v = | Val_bool true -> "#t" | Val_bool false -> "#f" | Val_int i -> string_of_int i + | Val_string s -> Printf.sprintf "%S" s | Val_prim _ -> "[primitive function]" | Val_lambda _ -> "[lambda expression]" ;; diff --git a/env.mli b/env.mli index 61a27ea..61ad6e1 100644 --- a/env.mli +++ b/env.mli @@ -6,7 +6,8 @@ type value = | Val_unit | Val_bool of bool | Val_int of int - | Val_prim of (value list -> value) (* primitive functions *) + | Val_string of string + | Val_prim of (env -> value list -> value) (* primitive functions *) | Val_lambda of env * id list * Ast.expr list (** Type of environments. *) diff --git a/eval.ml b/eval.ml index f524b92..b74cd65 100644 --- a/eval.ml +++ b/eval.ml @@ -7,6 +7,7 @@ let rec eval ast env = | Ast.Expr_unit -> Val_unit | Ast.Expr_bool b -> Val_bool b | Ast.Expr_int i -> Val_int i + | Ast.Expr_string s -> Val_string s | Ast.Expr_id id -> lookup env id | Ast.Expr_define (id, e) -> let value = eval e env in @@ -24,7 +25,7 @@ let rec eval ast env = (* Evaluate the function argument (the first argument). *) let f = eval e env in (match f with - | Val_prim prim_func -> prim_func operands + | Val_prim prim_func -> prim_func env operands | Val_lambda (env', ids, exprs) -> if List.length ids <> List.length operands then raise (Type_error "Applied to wrong operands"); diff --git a/examples/my_lib.bs b/examples/my_lib.bs new file mode 100644 index 0000000..2475710 --- /dev/null +++ b/examples/my_lib.bs @@ -0,0 +1,3 @@ +(define say-hello + (lambda () + (print "hello"))) diff --git a/examples/test_my_lib.bs b/examples/test_my_lib.bs new file mode 100644 index 0000000..e7cbb67 --- /dev/null +++ b/examples/test_my_lib.bs @@ -0,0 +1,3 @@ +(load "my_lib.bs") + +(say-hello) diff --git a/lexer.mll b/lexer.mll index d272462..f25ccb3 100644 --- a/lexer.mll +++ b/lexer.mll @@ -7,7 +7,7 @@ let digit = ['0' - '9'] let integer = '-'? digit+ let id_chars = ['a' - 'z' '+' '-' '*' '/' '=' '<' '>' '!'] let comment = ';' [^ '\n']* -let identifier = id_chars (id_chars | digit)* +let identifier = id_chars (id_chars | digit)* '?'? rule lex = parse | comment { lex lexbuf } @@ -19,5 +19,15 @@ rule lex = parse | "#f" { TOK_BOOL false } | integer { TOK_INT (int_of_string (Lexing.lexeme lexbuf)) } | identifier { TOK_ID (Lexing.lexeme lexbuf) } + | '"' { lex_string (Buffer.create 16) lexbuf } | eof { TOK_EOF } | _ { failwith ("Unexpected char: " ^ Lexing.lexeme lexbuf) } + +and lex_string buf = parse + | '"' { TOK_STRING (Buffer.contents buf) } + | '\\' '\\' { Buffer.add_char buf '\\'; lex_string buf lexbuf } + | '\\' '\n' { Buffer.add_char buf '\n'; lex_string buf lexbuf } + | '\\' '"' { Buffer.add_char buf '"'; lex_string buf lexbuf } + | [^ '"' '\\'] { Buffer.add_string buf (Lexing.lexeme lexbuf); lex_string buf lexbuf } + | eof { failwith "String is not terminated" } + | _ { failwith ("Illegal string character: " ^ Lexing.lexeme lexbuf) } diff --git a/main.ml b/main.ml index 18d152e..e681bb5 100644 --- a/main.ml +++ b/main.ml @@ -64,6 +64,7 @@ let () = | [| _; "-h" |] | [| _; "--help" |] | [| _; "help" |] -> usage () | [| _; filename |] -> let infile = open_in filename in + Sys.chdir (Filename.dirname filename); (try run_program infile with | e -> (match e with diff --git a/parser.mly b/parser.mly index 84c8faf..2afd307 100644 --- a/parser.mly +++ b/parser.mly @@ -3,6 +3,7 @@ %token TOK_UNIT %token TOK_BOOL %token TOK_INT +%token TOK_STRING %token TOK_ID %token TOK_EOF @@ -26,10 +27,11 @@ sexpr: ; atom: - | TOK_UNIT { Sexpr.Atom_unit } - | b = TOK_BOOL { Sexpr.Atom_bool b } - | i = TOK_INT { Sexpr.Atom_int i } - | id = TOK_ID { Sexpr.Atom_id id } + | TOK_UNIT { Sexpr.Atom_unit } + | b = TOK_BOOL { Sexpr.Atom_bool b } + | i = TOK_INT { Sexpr.Atom_int i } + | s = TOK_STRING { Sexpr.Atom_string s } + | id = TOK_ID { Sexpr.Atom_id id } ; slist: diff --git a/primitives.bs b/primitives.bs new file mode 100644 index 0000000..c14c6a7 --- /dev/null +++ b/primitives.bs @@ -0,0 +1,35 @@ +(define not + (lambda (b) + (if b + #f + #t))) + +(define zero? + (lambda (x) + (if (= x 0) + #t + #f))) + +(define positive? + (lambda (x) + (if (> x 0) + #t + #f))) + +(define negative? + (lambda (x) + (if (< x 0) + #t + #f))) + +(define min + (lambda (x y) + (if (< x y) + x + y))) + +(define max + (lambda (x y) + (if (> x y) + x + y))) diff --git a/primitives.ml b/primitives.ml index 04e7e0d..1534b81 100644 --- a/primitives.ml +++ b/primitives.ml @@ -6,13 +6,13 @@ open Env (* Create an arithmetic operator mapping an arbitrary number of integers to an integer. *) -let make_arith_operator op init name values = +let make_arith_operator op init name _ values = let err_msg = name ^ " requires integer arguments only" in let rec iter rest current = match rest with | [] -> current | Val_int i1 :: rest' -> iter rest' (op current i1) - | _ -> raise (Invalid_argument err_msg) + | _ -> invalid_arg err_msg in Val_int (iter values init) ;; @@ -22,45 +22,89 @@ let add = make_arith_operator ( + ) 0 "+" let mul = make_arith_operator ( * ) 1 "+" (* Subtract two integers. *) -let sub values = +let sub _ values = match values with | [ Val_int i1 ] -> Val_int (-i1) (* Unary minus *) | [ Val_int i1; Val_int i2 ] -> Val_int (i1 - i2) - | _ -> raise (Invalid_argument "- requires exactly one or two integer arguments") + | _ -> invalid_arg "- requires exactly one or two integer arguments" ;; (* Divide two integers. *) -let div values = +let div _ values = match values with | [ Val_int i1; Val_int i2 ] -> Val_int (i1 / i2) - | _ -> raise (Invalid_argument "/ requires exactly two integer arguments") + | _ -> invalid_arg "/ requires exactly two integer arguments" ;; (* Create a boolean operator acting on two integers. *) -let make_binary_bool_operator op name = +let make_int_int_bool_operator op name _ = let err_msg = name ^ " requires exactly two integer arguments" in function | [ Val_int i1; Val_int i2 ] -> Val_bool (op i1 i2) - | _ -> raise (Invalid_argument err_msg) + | _ -> invalid_arg err_msg ;; (* Define binary operators. *) -let eq = make_binary_bool_operator ( = ) "=" -let ne = make_binary_bool_operator ( <> ) "!=" -let lt = make_binary_bool_operator ( < ) "<" -let gt = make_binary_bool_operator ( > ) ">" -let le = make_binary_bool_operator ( <= ) "<=" -let ge = make_binary_bool_operator ( >= ) ">=" +let eq = make_int_int_bool_operator ( = ) "=" +let ne = make_int_int_bool_operator ( <> ) "!=" +let lt = make_int_int_bool_operator ( < ) "<" +let gt = make_int_int_bool_operator ( > ) ">" +let le = make_int_int_bool_operator ( <= ) "<=" +let ge = make_int_int_bool_operator ( >= ) ">=" (* Print a value. *) -let print values = +let print _ values = let err_msg = "print requires exactly one argument" in match values with | [ value ] -> Printf.printf "%s\n" (string_of_value value); flush stdout; Val_unit - | _ -> raise (Invalid_argument err_msg) + | _ -> invalid_arg err_msg +;; + +let and' _ = function + | [] -> Val_bool true + | [ x ] -> x + | [ Val_bool b; y ] -> if b then y else Val_bool false + | _ -> invalid_arg "and requires less than three arguments" +;; + +let or' _ = function + | [] -> Val_bool false + | [ x ] -> x + | [ (Val_bool b as x); y ] -> if b then x else y + | _ -> invalid_arg "or requires less than three arguments" +;; + +let load_from_lexbuf env lexbuf = + let rec loop () = + match Parser.parse Lexer.lex lexbuf with + | None -> () + | Some sexpr -> + let ast = Ast.ast_of_sexpr sexpr in + ignore @@ Eval.eval ast env; + loop () + in + loop () +;; + +let load_from_string env input = + let lexbuf = Lexing.from_string input in + load_from_lexbuf env lexbuf +;; + +let load_from_file env = function + | [ Val_string filename ] -> + let inx = open_in filename in + let lexbuf = Lexing.from_channel inx in + let origin_cwd = Sys.getcwd () in + Sys.chdir (Filename.dirname filename); + load_from_lexbuf env lexbuf; + close_in inx; + Sys.chdir origin_cwd; + Val_unit + | _ -> invalid_arg "load requires exactly one string argument" ;; (* Load the primitive functions into an environment, @@ -79,7 +123,11 @@ let load env = ; le, "<=" ; ge, ">=" ; print, "print" + ; load_from_file, "load" + ; and', "and" + ; or', "or" ] in - List.iter (fun (op, name) -> Env.add env name (Val_prim op)) ops + List.iter (fun (op, name) -> Env.add env name (Val_prim op)) ops; + load_from_string env Embed.primitives_dot_bs ;; diff --git a/sexpr.ml b/sexpr.ml index 8e4bab9..8f6a9ca 100644 --- a/sexpr.ml +++ b/sexpr.ml @@ -2,6 +2,7 @@ type atom = | Atom_unit | Atom_bool of bool | Atom_int of int + | Atom_string of string | Atom_id of string type expr = @@ -14,6 +15,7 @@ let string_of_atom a = | Atom_unit -> "#u" | Atom_bool b -> if b then "#t" else "#f" | Atom_int i -> string_of_int i + | Atom_string s -> Printf.sprintf "%S" s | Atom_id s -> s ;; diff --git a/sexpr.mli b/sexpr.mli index 519e8c9..3085e56 100644 --- a/sexpr.mli +++ b/sexpr.mli @@ -3,6 +3,7 @@ type atom = | Atom_unit | Atom_bool of bool | Atom_int of int + | Atom_string of string | Atom_id of string (** Type of all S-expressions. *) diff --git a/test/eval.ml b/test/eval.ml index 47cb66a..ff5de30 100644 --- a/test/eval.ml +++ b/test/eval.ml @@ -48,6 +48,20 @@ let tests = \ 1\n\ \ (* n (factorial (- n 1))))))\n\n\ (factorial number)" + ; make_eval_test "and_0" (Val_bool true) "(and)" + ; make_eval_test "and_1" (Val_int 1) "(and 1)" + ; make_eval_test "and_2_#t" (Val_int 1) "(and #t 1)" + ; make_eval_test "and_2_#f" (Val_bool false) "(and #f 1)" + ; make_eval_test "and_2_t_t" (Val_bool true) "(and #t #t)" + ; make_eval_test "or_0" (Val_bool false) "(or)" + ; make_eval_test "or_1" (Val_int 1) "(or 1)" + ; make_eval_test "or_2_#t" (Val_bool true) "(or #t 1)" + ; make_eval_test "or_2_#f" (Val_int 1) "(or #f 1)" + ; make_eval_test "or_2_f_t" (Val_bool true) "(or #f #t)" + ; make_eval_test "negative1" (Val_bool false) "(negative? 1)" + ; make_eval_test "negative2" (Val_bool true) "(negative? -1)" + ; make_eval_test "min" (Val_int 1) "(min 1 2)" + ; make_eval_test "max" (Val_int 2) "(max 1 2)" ] ;; diff --git a/test/lexer.ml b/test/lexer.ml index 83b4ba3..12684e6 100644 --- a/test/lexer.ml +++ b/test/lexer.ml @@ -9,6 +9,7 @@ let string_of_token = function | TOK_UNIT -> "UNIT" | TOK_BOOL b -> if b then "#t" else "#f" | TOK_INT i -> string_of_int i + | TOK_STRING s -> Printf.sprintf "%S" s | TOK_ID id -> id | TOK_EOF -> "EOF" ;; @@ -33,6 +34,7 @@ let make_lexer_test name expected_output input = let tests = [ make_lexer_test "int" [ TOK_INT 123 ] "123" ; make_lexer_test "neg_int" [ TOK_INT (-123) ] "-123" + ; make_lexer_test "string" [ TOK_STRING "abc" ] "\"abc\"" ; make_lexer_test "unit" [ TOK_UNIT ] "#u" ; make_lexer_test "bool_true" [ TOK_BOOL true ] "#t" ; make_lexer_test "bool_false" [ TOK_BOOL false ] "#f"