Started work on the compiler, with a desugar phase

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

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

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]
-  | _ -> [];;

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