Implement load and some mathematical functions

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

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))

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

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)

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"
+;;

embed.mli

@@ -0,0 +1 @@
+val primitives_dot_bs : string

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]"
 ;;

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. *)

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");

examples/my_lib.bs

@@ -0,0 +1,3 @@
+(define say-hello
+  (lambda ()
+    (print "hello")))

examples/test_my_lib.bs

@@ -0,0 +1,3 @@
+(load "my_lib.bs")
+
+(say-hello)

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) }

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

parser.mly

@@ -3,6 +3,7 @@
 %token          TOK_UNIT
 %token <bool>   TOK_BOOL
 %token <int>    TOK_INT
+%token <string> TOK_STRING
 %token <string> 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:

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)))

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
 ;;

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
 ;;
 

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. *)