diff --git a/bin/comp.ml b/bin/comp.ml new file mode 100644 index 0000000..24efcea --- /dev/null +++ b/bin/comp.ml @@ -0,0 +1,27 @@ + +open Parser.Ast;; + +let p = Printf.sprintf + +let rec dbg_print = function + | LSymbol s -> p "%s" s + | LCons (a, LNil) -> p "%s)" (dbg_print_start a) + | LCons (a, b) -> p "%s %s" (dbg_print_start a) (dbg_print b) + | LNil -> p "()" + | LInt i -> p "%d" i + | LDouble d -> p "%f" d + | LString s -> p "%s" s + +and dbg_print_start = function + | LCons (_, _) as l -> p "(%s" (dbg_print l) + | _ as x -> dbg_print x + + + +let def = Parser.parse_str "(define (f x) (+ x 1)) + (define (f) + (define (g y) (* y 2)) + (g 5))";; +let desugared = List.map Compiler.Sugar.desugar def +let () = List.iter (fun x -> Printf.printf "%s\n" (dbg_print_start x) ) desugared +let () = print_newline () diff --git a/bin/dune b/bin/dune index ea49d56..90bbdf0 100644 --- a/bin/dune +++ b/bin/dune @@ -3,3 +3,8 @@ (public_name ollisp-inter) (libraries str unix interpreter) (package ollisp)) + +(executable + (name comp) + (public_name ollisp) + (libraries str unix compiler interpreter)) diff --git a/lib/compiler/compilation.ml b/lib/compiler/compilation.ml index 4fea293..139597f 100644 --- a/lib/compiler/compilation.ml +++ b/lib/compiler/compilation.ml @@ -1,25 +1,2 @@ -open Parser.Ast;; - -(* This type represents an intermediate step between the AST and opcodes in our - compiler. We need this extra step to resolve addresses, e.g. how do you know - what exact address an if expression needs to jump to before you compile it? - you don't, you just keep a symbolic label there, resolve later. - *) -type intermediate_opcode = - | ISelect of string * string - | ILDF of string - | ILD of int (* an index into the constant table *) - | INil - | IRet - | IAdd - | IJoin - | ILabel of string (* does not emit any byte code *) - - - -(* TODO: Complete *) -let (compile : lisp_ast -> intermediate_opcode list) = function - | LInt x -> [ILD x] - | _ -> [];; diff --git a/lib/compiler/sugar.ml b/lib/compiler/sugar.ml new file mode 100644 index 0000000..88a23a0 --- /dev/null +++ b/lib/compiler/sugar.ml @@ -0,0 +1,77 @@ + + +(* In this module we handle syntax sugar, i.e. simple built-in transformations + on source code. + + Examples: + (define (f x) ...) = (define f (lambda (x) ...)) + *) + +open Parser.Ast + +let rec sexpr_to_list = function + | LCons (a, b) -> a :: (sexpr_to_list b) + | LNil -> [] + | _ -> failwith "Not proper list!" +let rec list_to_sexpr = function + | a :: b -> LCons (a, list_to_sexpr b) + | [] -> LNil + +let rec sexpr_map f = function + | LCons (a, b) -> LCons (f a, sexpr_map f b) + | LNil -> LNil + | _ -> failwith "Not proper list!!!" + + +(* This MUST be called after function definitions have been desugared, + i.e. desugar_define_functions has been called + *) +let rec collect_definitions = function + | LCons (LCons (LSymbol "define", LCons (LSymbol _ as var, LCons (value, LNil))), rest) -> + let (defs, rest) = collect_definitions rest in + LCons (LCons (var, LCons (value, LNil)), defs), rest + | rest -> LNil, rest + +let make_letrec body = + let (defs, rest) = collect_definitions body in + LCons (LSymbol "letrec", LCons (defs, rest)) + + +(* (define (f ...) ...) + into + (define f (lambda (...) ...)) + + *) +let rec desugar_define_function = function + | LCons (LSymbol "define", LCons (LCons (LSymbol _ as sym, args), body)) -> + let body = sexpr_map desugar body in + let lamb = LCons (LSymbol "lambda", LCons (args, body)) in + let def = LCons (LSymbol "define", LCons (sym, LCons (lamb, LNil))) in + def + | LCons (_, _) as expr -> + sexpr_map desugar_define_function expr + | expr -> expr + + +and desugar_internal_define = function + | LCons (LSymbol "lambda", LCons (args, body)) -> + LCons (LSymbol "lambda", LCons (args, (LCons (make_letrec body, LNil)))) + | LCons (_, _) as expr -> + sexpr_map desugar_internal_define expr + | expr -> expr +(* Turn all lambda and define bodies into begins *) +and beginize = function + | LCons (LSymbol "lambda", LCons (args, body)) -> + let body = (match body with + | LCons (_, LCons (_, _)) as b -> + LCons (LSymbol "begin", b) + | _ -> body) in + LCons (LSymbol "lambda", LCons (args, body)) + | LCons (_, _) as expr -> + sexpr_map beginize expr + | expr -> expr + +and desugar x = + x + |> desugar_define_function + |> desugar_internal_define