scope_analysis: fix the handling of Lambda forms

core_ast: related to the above, reorganized core_ast to use the new syntactic ast

.woodpecker/debian.yaml

@@ -0,0 +1,12 @@
+when:
+  event: [push, cron, pull_request, manual]
+
+steps:
+  - name: Build on Debian
+    image: debian:13
+    pull: true
+    commands:
+      - apt update && apt full-upgrade -y
+      - apt install -y ocaml libfindlib-ocaml-dev ocaml-dune menhir
+      - dune build
+      - dune exec ollisp

.woodpecker/fedora.yaml

@@ -0,0 +1,12 @@
+when:
+  event: [push, cron, pull_request, manual]
+
+steps:
+  - name: Build on Fedora
+    image: fedora:43
+    pull: true
+    commands:
+      - dnf update -y
+      - dnf install -y ocaml ocaml-findlib menhir dune
+      - dune build
+      - dune exec ollisp

.woodpecker/nix.yaml

@@ -1,9 +1,10 @@
+when:
+  event: [push, cron, pull_request, manual]
 
 steps:
-  - name: build-nix
+  - name: Build on NixOS
     image: nixos/nix:latest
-    when:
+    pull: true
-      event: [tag, push]
     commands:
       - nix --extra-experimental-features nix-command --extra-experimental-features flakes build
       - ./result/bin/ollisp

.woodpecker/publish.yaml

@@ -0,0 +1,21 @@
+when:
+  event: [push, cron, pull_request, manual]
+
+steps:
+  - name: Build Nightly Artifact
+    image: ocaml/opam:debian-11-ocaml-5.4
+    commands:
+      - opam install . --deps-only
+      - opam exec -- dune build
+      - mkdir -p dist
+      - opam exec -- dune install --prefix=$(pwd)/dist
+
+      - tar czvf ollisp-nightly-amd64.tar.gz -C dist .
+  - name: Publish to Gitea
+    image: curlimages/curl
+    environment:
+      GITEA_TOKEN:
+        from_secret: package_token
+    commands:
+      - curl -v --user "$CI_REPO_OWNER:$GITEA_TOKEN" --upload-file ollisp-nightly-amd64.tar.gz $CI_FORGE_URL/api/packages/$CI_REPO_OWNER/generic/olisp/nightly/ollisp-nightly-amd64.tar.gz?duplicate_upgrade=true
+  

LICENSE

@@ -0,0 +1,21 @@
+MIT License
+
+Copyright (c) 2026 Emin Arslan
+
+Permission is hereby granted, free of charge, to any person obtaining a copy
+of this software and associated documentation files (the "Software"), to deal
+in the Software without restriction, including without limitation the rights
+to use, copy, modify, merge, publish, distribute, sublicense, and/or sell
+copies of the Software, and to permit persons to whom the Software is
+furnished to do so, subject to the following conditions:
+
+The above copyright notice and this permission notice shall be included in all
+copies or substantial portions of the Software.
+
+THE SOFTWARE IS PROVIDED "AS IS", WITHOUT WARRANTY OF ANY KIND, EXPRESS OR
+IMPLIED, INCLUDING BUT NOT LIMITED TO THE WARRANTIES OF MERCHANTABILITY,
+FITNESS FOR A PARTICULAR PURPOSE AND NONINFRINGEMENT. IN NO EVENT SHALL THE
+AUTHORS OR COPYRIGHT HOLDERS BE LIABLE FOR ANY CLAIM, DAMAGES OR OTHER
+LIABILITY, WHETHER IN AN ACTION OF CONTRACT, TORT OR OTHERWISE, ARISING FROM,
+OUT OF OR IN CONNECTION WITH THE SOFTWARE OR THE USE OR OTHER DEALINGS IN THE
+SOFTWARE.

bin/comp.ml

@@ -1,24 +1,7 @@
 
-open Parser.Ast;;
+let def = Parser.parse_str "(define (f)
-
+                             (let ((x 5))
-let p = Printf.sprintf
+                              (if t (set! x (+ x 1)))))
-
-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))
                               (or (g 5) (g 6)))
@@ -26,6 +9,14 @@ let def = Parser.parse_str "(define (f x) (+ x 1))
                              ((> 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 ( let* ) = Result.bind;;
-let () = print_newline ()
+let e =
+  (*let def = Parser.parse_str "(lambda () (+ x 1) (+ x 1))" in
+   *)
+  let* top = Compiler.Syntactic_ast.make (List.hd def) in
+  Ok (Printf.printf "%s\n" (Compiler.Syntactic_ast.print top))
+
+let _ = match e with
+  | Error s -> Printf.printf "%s\n" s
+  | _ -> ()

doc/env.md

@@ -0,0 +1,210 @@
+This document holds my design notes for lexical and global environments
+for this compiler. I have not yet named the language.
+
+# Closures
+
+The environment system implements flat closures.
+When a closure is created at runtime, all free variables
+it uses are packaged as part of the function object, then the function
+body uses a GetFree instruction to get those free variables by an index.
+
+(Free variables are propagated from inner closures outwards. This is necessary,
+as this also handles multiple-argument functions gracefully.)
+
+```scheme
+(let ((a 10))
+  (print (+ a 5)))
+```
+
+This code will be compiled as a lambda that takes a single parameter and executes
+the body `(print (+ a 5))`, which is called immediately with the value 10.
+
+The compiler tries to perform symbol resolution on expressions in the body of the
+let as well, however it sees no other expressions creating further scopes.
+
+Since there are two free symbols in this code (`+` and `print`), and the surrounding
+environment does not have these two symbols defined locally, both of these symbols
+will be resolved to their global definitions directly.
+
+Now let's examine a classic example of closures:
+
+```scheme
+(define (adder x)
+  (lambda (y) (+ x y)))
+```
+
+The adder function takes an argument x, and creates returns a function that adds x
+to its argument.
+
+This is implemented by a compiler pass that resolves symbols. Starting from top-level
+expressions, it scans downwards, noting every free symbol. A free symbol is one
+that is used in an expression, yet has no value defined locally in that expression.
+In other words, its value must come from the surrounding scope.
+
+In this example, the adder function has a symbol x that is a part of its function definition.
+This is clearly not a free variable. However, examining the inner lambda expression,
+we can see that it uses y (which is not free) and x. The value of x is not defined
+as part of the lambda expression, so it must be free.
+
+The compiler, seeing this, notes that the inner lambda has a free variable `x`, and a parameter
+`y`. Thus, the lambda has 1 free variable and 1 parameter. This means the closure object will have
+a code pointer along with an array of length 1 forming the storage for the free variable(s).
+The compiler compiles the body of the lambda such that every occurance of `x` is replaced
+with code to get free variable #0 from the current closure. (`y` is, naturally, parameter #0).
+Otherwise, no special handling is necessary.
+
+The inner lambda has no other expressions creating further scopes, so the compiler
+knows it has hit the deepest scope in the expression, and starts scanning outwards once again.
+
+Scanning outwards, the compiler sees that there is a defined symbol x, and in the scope
+of this definition, a lambda expression that uses a free symbol named x is used. The
+compiler matches these, and compiles the lambda expression (as in, the value that the lambda
+expression will evaluate to) such that it creates a closure object: a pair of code pointer
+pointing to the already compiled body, and an array of length 1 containing the current
+value of x.
+
+This newly created value represents the closure. As you might notice, the current value
+of x has been copied into the closure object. The closure is now returned, and the
+scope of `adder` is destroyed. The closure object survives.
+
+Note: in actuality, the outer `adder` function itself is also a closure. The inner
+lambda actually has *two* free variables: `+` is also a symbol, and its value is not
+defined in the body of the lambda. Since `adder` also doesn't define it, the free symbol
+is propagated outwards, and adder also accesses it as a free variable. The compiler
+(when propagating free symbols) eventually reaches the global environment, and
+resolves these free symbols to their global definitions.
+
+All global symbols are late-bound. Once the free symbol is propagated outwards to the global
+definition, the compiler must notice this and insert an instruction to get the
+value of a global symbol.
+
+Thus, the following will raise an error at runtime:
+
+```
+(define (adder x)
+  (lambda (y) (+ x y)))
+(set! '+ 5)
+; + now equals 5.
+(adder 5 5)
+```
+
+Since `5` is not a function, it cannot be called, and this will raise an error.
+
+## Note on boxing
+
+Closure conversion makes some situations a bit tricky.
+
+```
+(let ((x 10))
+  (let ((f (lambda () x))) ;; f captures x
+    (set! x 20)            ;; we change local x
+    (f)))                  ;; does this return 10 or 20?
+```
+
+In this case, instead of x being copied directly into the closure, a
+reference to its value is copied into the closure. This is usual in
+most schemes and lisps.
+
+In fact, you can even treat these as mutable state:
+
+```
+(define (make-counter)
+ (let ((count 0))
+  (lambda ()
+    (set! count (+ count 1))
+    count)))
+```
+
+So a closure can capture not just the value of a symbol, but also a
+reference to it. This reference survives the end of the `make-counter`
+function.
+
+## Note on currying
+
+Because this language is actually a curried variant of lisp/scheme, the
+above function could also be written like this:
+
+```scheme
+(define (adder x y) (+ x y))
+```
+
+or, even like this:
+
+```scheme
+(define adder +)
+```
+
+... since the built-in `+` function is also already curried. In fact, the entire
+language is curried. All function calls are (or behave as if they were) unary.
+The function call syntax `(f x y)` is actually treated as `((f x) y)` by the
+compiler.
+
+## Note on syntax
+
+I am using more or less regular Scheme syntax in this document. However, this is
+potentially subject to change. I have not decided on what the official syntax
+should be like. I am using Scheme syntax simply because I think it is fairly clean,
+but some changes might make sense in the future as the semantics of this language
+deviate greatly from Scheme's.
+
+## Note on performance
+
+This design document may raise concerns of performance. If everything above is
+truly set in stone, then it seems obvious that there should be a performance
+penalty.
+
+As written, this design requires a basic addition like `(+ 1 2)` to allocate a
+closure object after all. No matter how fast OCaml's minor heap may be
+(and it is plenty fast, to be fair), that is not going to go well in a tight loop. 
+
+These are valid concerns, and I am currently leaving these problems to my future
+self.
+
+Optimizing multiple-argument functions is actually fairly straightforward (or
+it looks easy, at least), however I want to first make sure the language
+has consistent semantics. A slow language is better than no language, after all.
+So I intend to add the facilities necessary for these optimizations into the
+compiler at a later point.
+
+## Global Definitions
+
+Global definitions get a separate section because they're mostly straightforward.
+
+Any symbol defined through a top-level `define` form is made globally available
+after the definition form. More accurately, the symbol is present in the program
+before the define is reached, however it will be bound to a dummy value until
+it is accessed.
+
+This behaviour is proposed for the purpose of allowing mutually
+recursive definitions without issue, however please note that this is not yet certain,
+because this design comes with the tradeoff that errors involving symbols accessed
+before the point they are supposed to be defined can only be detected at runtime.
+
+To illustrate the problems this could cause:
+
+```
+(define b (+ a 10))
+(define a 5)
+```
+
+This is pretty clearly an error - yet the compiler cannot, as proposed, determine
+this. In the future, further passes over the source code could be added to scan
+for such issues, or a differentiator between top-level function and variable
+definitions to prevent this.
+
+Notably, this problem does not occur for function definitions. In fact, the following
+is perfectly fine despite looking a bit similar:
+
+```
+(define (b) (+ a 10))
+(define a 5)
+```
+
+Generally any symbol appearing in the body of a function, will only be compiled
+to access that symbol. The symbol is only accessed once the function is called.
+Thus, you can create mutually recursive functions at the top level with no issue.
+
+The body of the definition is only executed once the `define` form is reached.
+Thus, definitions with side effects will execute exactly in the order they
+appear in the source.
+

dune-project

@@ -1,5 +1,7 @@
 (lang dune 3.7)
 (using menhir 2.1)
+(generate_opam_files true)
 
 (package
- (name ollisp))
+ (name ollisp)
+ (depends menhir))

flake.lock

@@ -20,11 +20,11 @@
     },
     "nixpkgs": {
       "locked": {
-        "lastModified": 1764950072,
+        "lastModified": 1766902085,
-        "narHash": "sha256-BmPWzogsG2GsXZtlT+MTcAWeDK5hkbGRZTeZNW42fwA=",
+        "narHash": "sha256-coBu0ONtFzlwwVBzmjacUQwj3G+lybcZ1oeNSQkgC0M=",
         "owner": "NixOS",
         "repo": "nixpkgs",
-        "rev": "f61125a668a320878494449750330ca58b78c557",
+        "rev": "c0b0e0fddf73fd517c3471e546c0df87a42d53f4",
         "type": "github"
       },
       "original": {

flake.nix

@@ -11,17 +11,21 @@
     pkgs = nixpkgs.legacyPackages.${system};
     devInputs = with pkgs.ocamlPackages; [merlin];
     ocamlPkgs = with pkgs.ocamlPackages; [menhir dune_3];
-    nativeInputs =  with pkgs; ocamlPkgs ++ [ocaml]; 
+    libs = with pkgs.ocamlPackages; [findlib];
+    nativeInputs =  with pkgs; ocamlPkgs ++ [ocaml];
   in
   {
-    packages.default = pkgs.ocamlPackages.buildDunePackage {
+    packages.default = (pkgs.ocamlPackages.buildDunePackage {
       pname = "ollisp";
       version = "0.0.1";
       src = pkgs.lib.cleanSource ./.;
       nativeBuildInputs = nativeInputs;
-    };
+      buildInputs = libs;
+    });
+    
     devShells.default = pkgs.mkShell {
       nativeBuildInputs = nativeInputs ++ devInputs;
+      buildInputs = libs;
     };
   });
 }

lib/compiler/compilation.ml

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

lib/compiler/core_ast.ml

@@ -0,0 +1,123 @@
+
+type literal =
+  | Int of int
+  | Double of float
+  | String of string
+  | Nil
+  | Cons of literal * literal
+
+(* The Core Abstract Syntax Tree.
+   This tree does not use a GADT, as every type of expression
+   will be reduced to its simplest equivalent form before ending
+   up here. There is no reason to make this tree typed.
+ *)
+type expression =
+  | Literal of literal
+  | Var of string
+  | Apply of expression * expression
+  | Lambda of string * expression
+  | If of expression * expression * expression
+  | Set of string * expression
+  | Begin of expression list
+
+
+type top_level =
+  | Define of string * expression
+  | Expr of expression
+
+
+
+let rec pair_of_def : Syntactic_ast.def -> string * expression =
+  fun (s, e) -> (s, of_expr e)
+and pair_of_binding (s, e) = (s, of_expr e)
+and pair_of_clause (e1, e2) = (of_expr e1, of_expr e2)
+
+and make_lambda args body =
+  match args with
+    (* TODO: gensym here instead of using _ directly *)
+  | [] -> Lambda ("_", of_body body)
+  | x :: [] -> Lambda (x, of_body body)
+  | x :: xs -> Lambda (x, make_lambda xs body)
+
+and make_apply f args =
+  let rec aux f = function
+    | [] -> Apply (f, Literal Nil)
+    | 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...
+  (((lambda (x) (lambda (y) ((f x) y)))  5)  4)
+ *)
+and make_let bs body =
+  let bs = List.map pair_of_binding bs in
+  let rec aux = function
+    | (s, e) :: rest ->
+       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
+   it makes sense to convert the body into a normal letrec.
+ *)
+and of_body : Syntactic_ast.body -> expression = function
+  | ([], exprs) ->
+     let exprs = List.map of_expr exprs in
+     Begin exprs
+  | (defs, exprs) ->
+     let exprs = List.map of_expr exprs in
+     let defs = List.map pair_of_def defs in
+     make_letrec defs exprs
+
+(* TODO: currently this ignores the "optional" part of the lambda list,
+   fix this *)
+and of_ll : Syntactic_ast.lambda_list -> string list = function
+  | (sl, _) -> sl
+
+and of_literal : Syntactic_ast.literal -> literal  = function
+  | LitInt x -> Int x
+  | LitDouble x -> Double x
+  | LitString x -> String x
+  | LitCons (a, b) -> Cons (of_literal a, of_literal b)
+  | LitNil -> Nil
+  
+and of_expr : Syntactic_ast.expr -> expression = function
+  | Literal l -> Literal (of_literal l)
+  | Var x -> Var x
+  | Lambda (ll, b) -> make_lambda (of_ll ll) b
+  | Let (bindings, b) -> make_let bindings 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))
+       (List.map pair_of_clause clauses)
+       (Literal Nil)
+  | If (e1, e2, e3) ->
+     If (of_expr e1, of_expr e2, of_expr e3)
+  | Set (s, e) -> Set (s, of_expr e)
+  | Apply (f, es) -> make_apply (of_expr f) (List.map of_expr es)
+
+
+and of_syntactic : Syntactic_ast.top_level -> top_level = function
+  | Def (s, e) -> Define (s, of_expr e)
+  | Exp (e) -> Expr (of_expr e)
+  | _ -> .
+
+
+let of_sexpr x =
+  Result.bind (Syntactic_ast.make x)
+    (fun x -> Ok (of_syntactic x))

lib/compiler/scope_analysis.ml

@@ -0,0 +1,104 @@
+
+
+module SymbolTable = Map.Make(String);;
+
+let ( let* ) = Result.bind
+let traverse = Util.traverse
+
+(* literals are not modified. *)
+type literal = Core_ast.literal
+
+(* Note:
+   all symbol accesses are replaced with either a local or global access.
+   Local accesses a symbol in the local scope.
+   Global accesses a symbol in the global scope.
+
+   Lambda expressions are stripped of the symbol name of their single parameter.
+   This name is not needed at runtime, as all symbol accesses will be resolved
+   into an index into either the local scope linked list or the global symbol table.
+
+   Set is also split into its global and local versions, just like Var. 
+
+   The rest aren't modified at all.
+ *)
+type expression =
+  | Literal of literal
+  | Local of int
+  | Global of int
+  | Apply of expression * expression
+  | Lambda of expression
+  | If of expression * expression * expression
+  | SetLocal of int * expression
+  | SetGlobal of int * expression
+  | Begin of expression list
+
+
+(* extract all defined global symbols, given the top-level expressions
+   and definitions of a program
+
+   The returned table maps symbol names to unique integers, representing
+   an index into a global array where the values of all global symbols will
+   be kept at runtime.
+ *)
+let extract_globals (top : Core_ast.top_level list) =
+  let id_counter = (ref (-1)) in
+  let id () =
+    id_counter := !id_counter + 1; !id_counter in
+  let rec aux tbl = function
+    | [] -> tbl
+    | Core_ast.Define (sym, _) :: rest ->
+       aux (SymbolTable.add sym (id ()) tbl) rest
+    | Expr _ :: rest ->
+       aux tbl rest
+  in aux SymbolTable.empty top
+
+(* The current lexical scope is simply a linked list of entries,
+   and each symbol access will be resolved as an access to an index
+   in this linked list. The symbol names are erased before runtime.
+   During this analysis we keep the lexical scope as a linked list of
+   symbols, and we find the index by traversing this linked list.
+ *)
+
+let resolve_global tbl sym =
+  match SymbolTable.find_opt sym tbl with
+  | Some x -> Ok (Global x)
+  | None -> Error ("symbol " ^ sym ^ " is not defined!")
+
+let resolve_lexical tbl env sym =
+  let rec aux counter = function
+    | [] -> resolve_global tbl sym
+    | x :: _ when String.equal x sym -> Ok (Local counter)
+    | _ :: rest -> aux (counter + 1) rest
+  in aux 0 env
+
+let resolve_symbol tbl env sym =
+  resolve_lexical tbl env sym
+
+let resolve_set tbl env sym expr =
+  let* sym = resolve_symbol tbl env sym in
+  match sym with
+  | Local i -> Ok (SetLocal (i, expr))
+  | Global i -> Ok (SetGlobal (i, expr))
+  | _ -> Error "resolve_set: symbol resolution returned something invalid."
+
+let rec analyze tbl current = function
+  | Core_ast.Literal s -> Ok (Literal s)
+  | Var sym -> resolve_symbol tbl current sym
+  | Set (sym, expr) ->
+     let* inner = analyze tbl current expr in
+     resolve_set tbl current sym inner
+  | Lambda (s, body) ->
+     let* body = (analyze tbl (s :: current) body) in
+     Ok (Lambda body)
+  | Apply (f, e) ->
+     let* f = analyze tbl current f in
+     let* e = analyze tbl current e in
+     Ok (Apply (f, e))
+  | If (test, pos, neg) ->
+     let* test = analyze tbl current test in
+     let* pos = analyze tbl current pos in
+     let* neg = analyze tbl current neg in
+     Ok (If (test, pos, neg))
+  | Begin el ->
+     let* body = traverse (analyze tbl current) el in
+     Ok (Begin body)

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

lib/compiler/syntactic_ast.ml

@@ -0,0 +1,322 @@
+
+(* The entire point of this module is to transform a given sexpr tree into
+   an intermediary AST that directly represents the grammar.
+ *)
+
+(* Literals *)
+type literal =
+  | LitInt of int
+  | LitDouble of float
+  | LitString of string
+  | LitCons of literal * literal
+  | LitNil
+
+type lambda_list = string list * string option
+
+type expr =
+  | Literal of literal
+  | Lambda of lambda_list * body
+  | Let of (string * expr) list * body
+  | LetRec of (string * expr) list * body
+  | Cond of (expr * expr) list
+  | If of expr * expr * expr
+  | Set of string * expr
+  | Var of string
+  | Apply of expr * expr list
+and def = string * expr
+and body = def list * expr list
+
+(* On the top-level we only allow definitions and expressions *)
+type top_level =
+  | Def of def
+  | Exp of expr
+
+
+(* we use result here to make things nicer *)
+let ( let* ) = Result.bind
+let traverse = Util.traverse
+let map = List.map
+
+
+
+let unwrap_exp = function
+  | Ok (Exp x) -> Ok x
+  | Error _ as e -> e
+  | _ -> Error "Definition found in Expression context"
+let unwrap_def x =
+  let* x = x in
+  match x with
+  | Def d -> Ok d
+  | _ -> Error "Expression found in Definition context"
+let exp x = Ok (Exp x)
+let lit x = Ok (Exp (Literal x))
+let def x = Ok (Def x)
+
+
+open Parser.Ast
+
+let sexpr_car = function
+  | LCons (a, _) -> Ok a
+  | _ -> Error "cannot take car of expression."
+let sexpr_cdr = function
+  | LCons (_, d) -> Ok d
+  | _ -> Error "cannot take cdr of expression."
+let sexpr_cadr cons =
+  let* cdr = sexpr_cdr cons in
+  sexpr_car cdr
+let sexpr_cddr cons =
+  let* cdr = sexpr_cdr cons in
+  sexpr_cdr cdr
+let sexpr_caddr cons =
+  let* cddr = sexpr_cddr cons in
+  sexpr_car cddr
+
+let expect_sym = function
+  | LSymbol s -> Ok s
+  | _ -> Error "Expected symbol!"
+
+(* We must now transform the s-expression tree into a proper, typed AST
+   First, we need some utilities for transforming proper lists and s-expr conses.
+
+   TODO: add diagnostics, e.g. what sexpr, specifically, couldn't be turned to a list?
+   generally more debugging is needed in this module.
+ *)
+let rec list_of_sexpr = function
+  | LCons (i, next) ->
+     let* next = list_of_sexpr next in
+     Ok (i :: next)
+  | LNil -> Ok []
+  | _ -> Error "cannot transform sexpr into list, malformed sexpr!"
+
+(* parse the argument list of a lambda form *)
+let parse_lambda_list cons =
+  let rec aux acc = function
+    | LCons (LSymbol a, LSymbol b) ->
+       Ok (List.rev (a :: acc), Some b)
+    | LCons (LSymbol a, rest) ->
+       aux (a :: acc) rest
+    | LNil -> Ok (List.rev acc, None)
+    | _ -> Error "Improper lambda list."
+  in aux [] cons
+
+(* Is the given lisp_ast node a definition? *)
+let is_def = function
+    | LCons (LSymbol "define", _) -> true
+    | _ -> false
+
+(* These five functions all depend on each other, which is why they are
+   defined in this let..and chain.
+ *)
+let rec parse_body body =
+  (* This helper function separates the definitions and expressions from the body *)
+  let rec aux acc = function
+    | expr :: rest when is_def expr ->
+       aux (expr :: acc) rest
+    | rest ->
+       Ok (List.rev acc, rest)
+  in
+  let* body = list_of_sexpr body in
+  let* (defs, exprs) = aux [] body in  
+  (* Once the expressions and definitions are separated we must parse them, then
+     unpack them from the top_level type.
+   *)
+  let* defs = traverse (Fun.compose unwrap_def transform) defs in
+  let* exprs = traverse (Fun.compose unwrap_exp transform) exprs in
+  Ok (defs, exprs)
+
+and builtin_define cons = 
+  let* second = sexpr_cadr cons in
+  match second with
+  | LSymbol sym ->
+     (* regular, symbol/variable definition *)
+     let* third = sexpr_caddr cons in
+     let* value = unwrap_exp (transform third) in
+     Ok (Def (sym, value))
+  | LCons (LSymbol sym, ll) ->
+     (* function definition, we treat this as a define + lambda *)
+     let* lambda_list = parse_lambda_list ll in
+     let* body = sexpr_cddr cons in
+     let* body = parse_body body in
+     Ok (Def (sym, Lambda (lambda_list, body)))
+  | _ -> Error "invalid definition!"
+
+and builtin_lambda cons =
+  let* lambda_list = sexpr_cadr cons in
+  let* lambda_list = parse_lambda_list lambda_list in
+  let* body = sexpr_cddr cons in
+  let* body = parse_body body in
+  exp (Lambda (lambda_list, body))
+
+and parse_bindings cons =
+  let parse_one cons =
+    let* sym = sexpr_car cons in
+    let* sym = expect_sym sym in
+    let* expr = sexpr_cadr cons in
+    let* expr = unwrap_exp (transform expr) in
+    Ok (sym, expr)
+  in
+  let* l = list_of_sexpr cons in
+  traverse parse_one l
+
+and make_builtin_let f cons =
+  let* bindings = sexpr_cadr cons in
+  let* bindings = parse_bindings bindings in
+  let* body = sexpr_cddr cons in
+  let* body = parse_body body in
+  exp (f bindings body)
+
+and parse_clauses cons =
+  let parse_one cons =
+    let* test = sexpr_car cons in
+    let* test = unwrap_exp (transform test) in
+    let* expr = sexpr_cadr cons in
+    let* expr = unwrap_exp (transform expr) in
+    Ok (test, expr)
+  in
+  let* l = list_of_sexpr cons in
+  traverse parse_one l
+
+and builtin_cond cons =
+  let* clauses = sexpr_cdr cons in
+  let* clauses = parse_clauses clauses in
+  exp (Cond clauses)
+
+and builtin_if cons =
+  let* cons = sexpr_cdr cons in
+  let* test = sexpr_car cons in
+  let* test = unwrap_exp (transform test) in
+  let* then_branch = sexpr_cadr cons in
+  let* then_branch = unwrap_exp (transform then_branch) in
+  let* else_branch = (match sexpr_caddr cons with
+  | Error _ -> Ok LNil
+  | Ok x -> Ok x) in
+  let* else_branch = unwrap_exp (transform else_branch) in
+  exp (If (test, then_branch, else_branch))
+
+and builtin_set cons =
+  let* cons = sexpr_cdr cons in
+  let* sym = sexpr_car cons in
+  let* sym = (match sym with
+             | LSymbol s -> Ok s
+             | _ -> Error "cannot (set!) a non-symbol") in
+  let* expr = sexpr_cadr cons in
+  let* expr = unwrap_exp (transform expr) in
+  exp (Set (sym, expr))
+
+and apply f args =
+  let* args = list_of_sexpr args in
+  let* args = traverse (fun x -> unwrap_exp (transform x)) args in
+  let* f = unwrap_exp (transform f) in
+  exp (Apply (f, args))
+
+and builtin_symbol = function
+  | "define" -> builtin_define
+  | "lambda" -> builtin_lambda
+  | "let" -> (make_builtin_let (fun x y -> Let (x,y)))
+  | "letrec" -> (make_builtin_let (fun x y -> LetRec (x,y)))
+  | "cond" -> builtin_cond
+  | "if" -> builtin_if
+  | "set!" -> builtin_set
+  | _ -> (function
+       | LCons (f, args) -> apply f args
+       | _ -> Error "Invalid function application!")
+
+and transform : lisp_ast -> (top_level, string) result = function
+  | LInt x -> lit (LitInt x)
+  | LDouble x -> lit (LitDouble x)
+  | LString x -> lit (LitString x)
+  (* NOTE: not all symbols are automatically Variable expressions,
+     Some must be further parsed (such as inside a definition)
+   *)
+  | LSymbol x -> exp (Var x)
+  | LNil -> lit (LitNil)
+  | LCons (LSymbol s, _) as cons -> (builtin_symbol s) cons
+  | LCons (f, args) -> apply f args
+
+let make (expr : Parser.Ast.lisp_ast) : (top_level, string) result =
+  transform expr
+
+
+
+(* Printing, for debug purposes *)
+let pf = Printf.sprintf
+let rec print_lambda_list = function
+  | (strs, None) -> ("(" ^ (String.concat " " strs) ^ ")")
+  | (strs, Some x) -> ("(" ^ (String.concat " " strs) ^ " . " ^  x ^ ")")
+and print_let_binding x =
+  let (s, expr) = x in
+  pf "(%s %s)" s (print_expr expr)
+and print_bindings l =
+  ("(" ^ (String.concat "\n" (map print_let_binding l)) ^ ")")
+and print_clause x =
+  let (test, expr) = x in
+  pf "(%s %s)" (print_expr test) (print_expr expr)
+and print_clauses l =
+  (String.concat "\n" (map print_clause l))
+and  print_def = function
+  | (s, expr) ->
+     pf "(define %s
+           %s)" s (print_expr expr)
+and print_defs l =
+  String.concat "\n" (map print_def l)
+
+and print_literal = function
+  | LitDouble x -> pf "%f" x
+  | LitInt x -> pf "%d" x
+  | LitString x -> pf "\"%s\"" x
+  | LitNil -> pf "nil"
+  | LitCons (a, b) -> pf "(%s . %s)" (print_literal a) (print_literal b)
+
+and print_expr = function
+  | Literal l -> print_literal l
+  | Lambda (ll, (defs, exprs)) ->
+     pf "(lambda %s
+           ; DEFINITIONS
+           %s
+           ; BODY
+           %s)"
+       (print_lambda_list ll)
+       (String.concat "\n" (map print_def defs))
+       (String.concat "\n" (map print_expr exprs))
+  | Let (binds, (defs, exprs)) ->
+     pf "(let
+           ; BINDINGS
+           %s
+           ; DEFINITIONS
+           %s
+           ; EXPRESSIONS
+           %s)"
+       (print_bindings binds)
+       (print_defs defs)
+       (print_exprs exprs)
+  | LetRec (binds, (defs, exprs)) ->
+     pf "(letrec
+           ; BINDINGS
+           %s
+           ; BODY
+           %s
+           ; EXPRESSIONS
+           %s)"
+       (print_bindings binds)
+       (print_defs defs)
+       (print_exprs exprs)
+  | Cond (clauses) ->
+     pf "(cond
+           %s)"
+       (print_clauses clauses)
+  | Var s -> s
+  | If (e1, e2, e3) ->
+     pf "(if %s %s %s)" (print_expr e1) (print_expr e2) (print_expr e3)
+  | Set (s, expr) ->
+     pf "(set! %s %s)" s (print_expr expr)
+  | Apply (f, exprs) ->
+     pf "(apply %s %s)"
+       (print_expr f)
+       ("(" ^ (String.concat " " (map print_expr exprs)) ^ ")")
+(* | _ -> "WHATEVER" *)
+and print_exprs l =
+  String.concat "\n" (map print_expr l)
+
+let print = function
+  | Def x -> print_def x
+  | Exp x -> print_expr x

lib/compiler/util.ml

@@ -0,0 +1,9 @@
+let ( let* ) = Result.bind
+
+let traverse f l =
+  let rec aux acc = function
+    | x :: xs ->
+       let* result = f x in
+       aux (result :: acc) xs
+    | [] -> Ok (List.rev acc) in
+  aux [] l

ollisp.opam

@@ -0,0 +1,21 @@
+# This file is generated by dune, edit dune-project instead
+opam-version: "2.0"
+depends: [
+  "dune" {>= "3.7"}
+  "menhir"
+  "odoc" {with-doc}
+]
+build: [
+  ["dune" "subst"] {dev}
+  [
+    "dune"
+    "build"
+    "-p"
+    name
+    "-j"
+    jobs
+    "@install"
+    "@runtest" {with-test}
+    "@doc" {with-doc}
+  ]
+]