core_ast: removed letrec. we now treat it as let + set.

bin/comp.ml

@@ -1,23 +1,4 @@
 
-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)
                              (let ((x 5))
                               (if t (set! x (+ x 1)))))
@@ -28,9 +9,6 @@ let def = Parser.parse_str "(define (f)
                              ((> 1 2) 0)
                              ((> 3 2) 3)
                              (t -1))";;
-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 ()
 
 let ( let* ) = Result.bind;;
 let e =

lib/compiler/compilation.ml

@@ -1,2 +0,0 @@
-
-

lib/compiler/core_ast.ml

@@ -16,7 +16,7 @@ type expression =
   | Var of string
   | Apply of expression * expression
   | Lambda of string * expression
-  | LetRec of (string * expression) list * expression
+  (*| LetRec of (string * expression) list * expression   *)
   | If of expression * expression * expression
   | Set of string * expression
   | Begin of expression list
@@ -46,6 +46,7 @@ and make_apply f args =
     | arg :: [] -> Apply (f, arg)
     | arg :: args -> aux (Apply (f, arg)) args
   in aux f args
+
 (* desugars this...
   (let ((x 5) (y 4)) (f x y))
   ... into this...
@@ -58,6 +59,17 @@ and make_let bs body =
        Apply (Lambda (s, aux rest), e)
     | [] -> of_body body in
   aux bs
+
+(* The Core AST does not feature a letrec node. Instead, we desugar letrecs further
+   into a let that binds each symbol to nil, then `set!`s them to their real value
+   before running the body.
+ *)
+and make_letrec bs exprs =
+  let tmp_bs = List.map (fun (s, _) -> (s, Literal Nil)) bs in
+  let setters = List.fold_right (fun (s, e) acc -> (Set (s, e)) :: acc) bs [] in
+  let body = Begin ((List.rev setters) @ exprs) in
+  List.fold_right (fun (s, e) acc -> Apply (Lambda (s, acc), e)) tmp_bs body
+
 (* We convert a body into a regular letrec form.
    A body is defined as a series of definitions followed by a series
    of expressions. The definitions behave exactly as a letrec, so
@@ -70,8 +82,7 @@ and of_body : Syntactic_ast.body -> expression = function
   | (defs, exprs) ->
      let exprs = List.map of_expr exprs in
      let defs = List.map pair_of_def defs in
-     let b = Begin exprs in
-     LetRec (defs, b)
+     make_letrec defs exprs
 
 (* TODO: currently this ignores the "optional" part of the lambda list,
    fix this *)
@@ -90,7 +101,7 @@ and of_expr : Syntactic_ast.expr -> expression = function
   | Var x -> Var x
   | Lambda (ll, b) -> make_lambda (of_ll ll) b
   | Let (bindings, b) -> make_let bindings b
-  | LetRec (bindings, b) -> LetRec (List.map pair_of_binding bindings, of_body b)
+  | LetRec (bindings, b) -> make_letrec (List.map pair_of_binding bindings) [(of_body b)]
   | Cond (clauses) -> 
      List.fold_right
        (fun (e1, e2) acc -> If (e1, e2, acc))

lib/compiler/sugar.ml

@@ -1,170 +0,0 @@
-
-
-(* 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
-
-(* Uses collect_definitions to rewrite a lambda body's (define) forms
-   into letrec
-   see desugar_internal_define
- *)
-let make_letrec body =
-  let (defs, rest) = collect_definitions body in
-  match defs with
-  | LNil -> rest
-  | _ -> LCons (LCons (LSymbol "letrec", LCons (defs, rest)), LNil)
-
-(* (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_define_function 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
-
-(* A lambda form's body must be a sequence of definitions, followed by
-   expressions to be evaluated.
-   This desugar phase rewrites the definitions (which must be at the start
-   of the lambda body) into a letrec form.
-
-   Example:
-   (lambda ()
-     (define (f) (display "hi"))
-     (f)
-     (f))
-   into:
-   (lambda ()
-     (letrec
-       ((f (lambda () (display "hi"))))
-       (f) (f)))  
- *)
-let rec desugar_internal_define = function
-  | LCons (LSymbol "lambda", LCons (args, body)) ->
-     LCons (LSymbol "lambda", LCons (args, (make_letrec body)))
-  | LCons (_, _) as expr ->
-     sexpr_map desugar_internal_define expr
-  | expr -> expr
-
-(* Turn bodies of lambdas and letrec's *)
-let rec beginize = function
-  | LCons (LSymbol "letrec" as sym, LCons (args, body))
-  | LCons (LSymbol "lambda" as sym, LCons (args, body)) ->
-     let body = beginize body in
-     let body = (match body with
-     | LCons (_, LCons (_, _)) as b ->
-        LCons (LCons (LSymbol "begin", b), LNil)
-     | _ -> body) in
-     LCons (sym, LCons (args, body))
-  | LCons (_, _) as expr ->
-     sexpr_map beginize expr
-  | expr -> expr
-
-(* These are helper functions for the logical and/or desugars. *)
-let make_single_let sym value body =
-  let val_list = LCons (sym, LCons (value, LNil)) in
-  let full_list = LCons (val_list, LNil) in
-  list_to_sexpr
-    [LSymbol "let"; full_list; body]
-
-let make_if cond t e =
-  list_to_sexpr
-    [LSymbol "if"; cond; t; e]
-
-let make_letif sym value cond t e =
-  make_single_let sym value
-    (make_if cond t e)
-
-(*
-  (or a b)
-  turns into
-  (let ((__generated_or1 a))
-   (if __generated_or1
-    __generated_or1
-    (let ((__generated_or2 b))
-     (if __generated_or2
-       __generated_or2
-       ()))))
- *)
-let rec desugar_logical_or = function
-  | LCons (LSymbol "or", LCons (f, rest)) ->
-     let sym = LSymbol (Gensym.gensym "or") in
-     let f = desugar_logical_or f in
-     let rest = LCons (LSymbol "or", rest) in
-     make_letif sym f sym sym (desugar_logical_or rest)
-  | LCons (LSymbol "or", LNil) ->
-     LNil (* TODO: Change this when/if you add #t/#f *)
-  | LCons (_, _) as expr ->
-     sexpr_map desugar_logical_or expr
-  | expr -> expr
-
-let rec desugar_logical_and = function
-  | LCons (LSymbol "and", LCons (first, rest)) ->
-     let sym = LSymbol (Gensym.gensym "and") in
-     let first = desugar_logical_and first in
-     let rest = LCons (LSymbol "and", rest) in
-     make_letif sym first sym (desugar_logical_and rest) sym
-  | LCons (LSymbol "and", LNil) ->
-     LSymbol "t" (* TODO: change this when/if you add #t/#f *)
-  | LCons (_, _) as expr ->
-     sexpr_map desugar_logical_and expr
-  | expr -> expr
-
-let rec cond_helper = function
-  | LCons (LCons (condition, then_), rest) ->
-     (* we need to desugar recursively, here as well. *)
-     let condition = desugar_cond condition in 
-     let then_ = desugar_cond then_ in
-     make_if condition (LCons (LSymbol "begin", then_)) (cond_helper rest)
-  | LNil -> LNil
-  | _ -> failwith "improper cond!" 
-
-and desugar_cond = function
-  | LCons (LSymbol "cond", (LCons (_, _) as conditions)) ->
-     cond_helper conditions
-  | LCons (_, _) as expr ->
-     sexpr_map desugar_cond expr
-  | expr -> expr
-     
-
-let desugar x =
-  x
-  |> desugar_define_function
-  |> desugar_internal_define
-  |> beginize
-  |> desugar_logical_or
-  |> desugar_logical_and
-  |> desugar_cond