haxala1r/olisp
1
0
Fork 0
Code Issues Pull Requests Packages Releases Wiki Activity

Complete reorganization: finally at a building state again

Browse Source
This commit is contained in:
Emin Arslan
2025-12-08 22:25:58 +03:00
parent 4faf309752
commit fb47e6ecdd
17 changed files with 36 additions and 590 deletions
Download Patch File Download Diff File Expand all files Collapse all files

6
bin/dune
View File

@@ -1,5 +1,5 @@
(executable (executable
(name inter) (name inter)
(public_name inter) (public_name ollisp-inter)
(libraries str interpreter unix) (libraries str unix interpreter)
(package main)) (package ollisp))

3
dune-project
View File

@@ -1,2 +1,5 @@
(lang dune 3.7) (lang dune 3.7)
(using menhir 2.1) (using menhir 2.1)
(package
(name ollisp))

27
flake.lock generated Normal file
View File

@@ -0,0 +1,27 @@
{
"nodes": {
"nixpkgs": {
"locked": {
"lastModified": 1764950072,
"narHash": "sha256-BmPWzogsG2GsXZtlT+MTcAWeDK5hkbGRZTeZNW42fwA=",
"owner": "NixOS",
"repo": "nixpkgs",
"rev": "f61125a668a320878494449750330ca58b78c557",
"type": "github"
},
"original": {
"owner": "NixOS",
"ref": "nixos-unstable",
"repo": "nixpkgs",
"type": "github"
}
},
"root": {
"inputs": {
"nixpkgs": "nixpkgs"
}
}
},
"root": "root",
"version": 7
}

142
interpreter/ast.ml
View File

@@ -1,142 +0,0 @@
(* This is different from the lisp_ast data returned by the parser!
We will first need to translate that into this in order to use it.
This representation includes things that can only occur during runtime,
like the various kinds of functions and macros.
Additionally, since this is an interpreter, macros tend to be a little
awkward in that they behave exactly like the macro gets expanded just
before the result gets executed. This is different from the compiled
behaviour where the macro is evaluated at compile time.
Though of course, with the dynamic nature of lisp, and its capability
to compile more code at runtime, there will naturally be complications.
*)
type lisp_val =
| LInt of int
| LDouble of float
| LCons of lisp_val * lisp_val
| LNil
| LSymbol of string
| LString of string
(* a builtin function is expressed as a name and the ocaml function
that performs the operation. The function should take a list of arguments.
generally, builtin functions should handle their arguments directly,
and eval forms in the environment as necessary. *)
| LBuiltinFunction of string * (environment -> lisp_val -> lisp_val)
| LBuiltinSpecial of string * (environment -> lisp_val -> lisp_val)
(* a function is a name, captured environment, a parameter list, and function body. *)
| LFunction of string * environment * lisp_val * lisp_val
| LLambda of environment * lisp_val * lisp_val
(* a macro is exactly the same as a function, with the distinction
that it receives all of its arguments completely unevaluated
*)
| LMacro of string * environment * lisp_val * lisp_val
| LUnnamedMacro of environment * lisp_val * lisp_val
| LQuoted of lisp_val
(* the environment type needs to be defined here, as it is mutually
recursive with lisp_val *)
and environment = (string, lisp_val) Hashtbl.t list
(* It is clear that we need some primitives for working with the lisp
data structures.
For example, the LCons and LNil values, together, form a linked list.
This is the intended form of all source code in lisp, yet because
we are using our own implementation of a linked list instead of
ocaml's List, we can not use its many functions.
It may be tempting to switch to a different implementation.
Remember however, that classic lisp semantics allow for the
CDR component of a cons cell (the part that would point to the
next member) to be of a type other than the list itself.
*)
let reverse vs =
let rec aux prev = function
| LNil -> prev
| LCons (v, next) -> aux (LCons (v, prev)) next
| _ -> invalid_arg "cannot reverse non-list!"
in aux LNil vs
let map f =
let rec aux accum = function
| LNil -> reverse accum
| LCons (v, next) -> aux (LCons (f v, accum)) next
| _ -> invalid_arg "cannot map over non-list!"
in aux LNil
let reduce init f =
let rec aux accum = function
| LNil -> accum
| LCons (v, next) -> aux (f accum v) next
| _ -> invalid_arg "cannot reduce over non-list!"
in aux init
let rec dbg_print_list =
let pf = Printf.sprintf in
function
| LCons (v, LNil) -> pf "%s" (dbg_print_one v)
| LCons (v, rest) -> (pf "%s " (dbg_print_one v)) ^ (dbg_print_list rest)
| v -> pf ". %s" (dbg_print_one v)
and dbg_print_one v =
let pf = Printf.sprintf in
match v with
| LInt x -> pf "<int: %d>" x
| LSymbol s -> pf "<symbol: '%s'>" s
| LString s -> pf "<string: '%s'>" s
| LNil -> pf "<nil>"
| LCons _ -> pf "<list: (%s)>" (dbg_print_list v)
| LDouble d -> pf "<double: %f>" d
| LBuiltinSpecial (name, _)
| LBuiltinFunction (name, _) -> pf "<builtin: %s>" name
| LLambda (_, args, _) -> pf "<unnamed function, lambda-list: %s>"
(dbg_print_one args)
| LFunction (name, _, args, _) -> pf "<function: '%s' lambda-list: %s>"
name (dbg_print_one args)
| LUnnamedMacro (_, args, _) -> pf "<unnamed macro, lambda-list: %s>"
(dbg_print_one args)
| LMacro (name, _, args, _) -> pf "<macro '%s' lambda-list: %s>"
name (dbg_print_one args)
| LQuoted v -> pf "<quote: %s>" (dbg_print_one v)
(*| _ -> "<Something else>"*)
let rec pretty_print_one v =
let pf = Printf.sprintf in
match v with
| LInt x -> pf "%d" x
| LSymbol s -> pf "%s" s
| LString s -> pf "\"%s\"" s
| LNil -> pf "()"
| LCons (a, b) -> pf "(%s)" (dbg_print_list (LCons (a,b)))
| LDouble d -> pf "%f" d
| LQuoted v -> pf "'%s" (pretty_print_one v)
| LBuiltinSpecial _
| LBuiltinFunction _
| LLambda _
| LFunction _
| LUnnamedMacro _
| LMacro _ -> dbg_print_one v
let pretty_print_all vs =
let pr v = Printf.printf "%s\n" (pretty_print_one v) in
List.iter pr vs
let dbg_print_all vs =
let pr v = Printf.printf "%s\n" (dbg_print_one v) in
List.iter pr vs
let rec convert_one = function
| Parser.Ast.LInt x -> LInt x
| Parser.Ast.LDouble x -> LDouble x
| Parser.Ast.LNil -> LNil
| Parser.Ast.LString s -> LString s
| Parser.Ast.LSymbol s -> LSymbol s
| Parser.Ast.LCons (a, b) -> LCons (convert_one a, convert_one b)
let read_from_str s =
List.map convert_one (Parser.parse_str s)

3
interpreter/dune
View File

@@ -1,3 +0,0 @@
(library
(name interpreter)
(libraries parser))

38
interpreter/env.ml
View File

@@ -1,38 +0,0 @@
open Ast
(* the type `environment` is defined in Ast *)
let default_env: environment = [Hashtbl.create 1024];;
let copy (env : environment) : environment =
List.map Hashtbl.copy env
let make_env () = copy default_env
let new_lexical (env : environment) : environment =
let h = Hashtbl.create 16 in
h :: env
let set_local (env : environment) (s : string) (v : lisp_val) : unit =
match env with
| [] -> ()
| e1 :: _ -> Hashtbl.replace e1 s v
let rec update (env : environment) s v =
match env with
| [] -> ()
| e1 :: erest ->
match Hashtbl.find_opt e1 s with
| None -> update erest s v
| Some _ -> Hashtbl.replace e1 s v
let rec get_root (env : environment) =
match env with
| [] -> raise (Invalid_argument "Empty environment passed to env_root!")
| e :: [] -> e
| _ :: t -> get_root t
let set_global (env : environment) s v =
Hashtbl.replace (get_root env) s v
let set_default s v =
set_global default_env s v

76
interpreter/eval.ml
View File

@@ -1,76 +0,0 @@
open Ast;;
(* the type annotations are unnecessary, but help constrain us from a
potentially more general function here *)
let rec eval_sym (env: environment) (s: string) =
match env with
| [] -> raise (Invalid_argument (Printf.sprintf "eval_sym: symbol %s has no value in current scope" s))
| e :: rest ->
match Hashtbl.find_opt e s with
| None -> eval_sym rest s
| Some v -> v
let rec eval_one env = function
| LSymbol s -> eval_sym env s
| LCons (func, args) -> eval_call env (eval_one env func) args
| LQuoted v -> v
| v -> v (* All other forms are self-evaluating *)
(* Evaluate a list of values, without evaluating the resulting
function or macro call. Since macros and functions inherently
look similar, they share a lot of code, which is extracted here *)
and eval_list env l =
match l with
| LNil -> LNil
| LCons (a, b) -> LCons (eval_one env a, eval_list env b)
| _ -> raise (Invalid_argument "eval_list: cannot process non-list")
and eval_body env body =
match body with
| LNil -> LNil
| LCons (form, LNil) -> eval_one env form
| LCons (form, next) -> ignore (eval_one env form); eval_body env next
| _ -> LNil
and bind_args env = function
| (LNil, LNil) -> ()
| (LSymbol s, v) -> Env.set_local env s v
| (LCons (LSymbol hl, tl), LCons (ha, ta)) -> Env.set_local env hl ha; bind_args env (tl, ta)
| _ -> invalid_arg "cannot bind argument list for function"
and eval_apply args = function
| LLambda (e, l, b)
| LFunction (_, e, l, b) ->
let lexical_env = Env.new_lexical e in
bind_args lexical_env (l, args);
eval_body lexical_env b
| LUnnamedMacro (e, l, b)
| LMacro (_, e, l, b) ->
let lexical_env = Env.new_lexical e in
bind_args lexical_env (l, args);
eval_body lexical_env b
| v ->
invalid_arg ("Non-macro non-function value passed to eval_apply "
^ dbg_print_one v)
and eval_call env func args =
match func with
| LBuiltinSpecial (_, f) -> f env args
| LBuiltinFunction (_, f) -> f env (eval_list env args)
(* The function calls don't happen in the calling environment,
so it makes no sense to pass env to a call. *)
| LLambda _
| LFunction _ -> eval_apply (eval_list env args) func
(* Macros are the same, they just return code that *will* be evaluated
in the calling environment *)
| LUnnamedMacro _
| LMacro _ -> eval_one env (eval_apply args func)
| v -> raise (Invalid_argument
(Printf.sprintf "eval_apply: cannot call non-function object %s" (dbg_print_one v)))
let eval_all env vs =
let ev v = eval_one env v in
List.map ev vs;;

204
interpreter/stdlib.ml
View File

@@ -1,204 +0,0 @@
open Ast;;
(* I feel like the more I get into functional programming, the more insane my code
becomes. What the fuck is this? why do I have a set of functions that combine
binary operators over an arbitrarily long list? I have like. 4 operators. None
of this matters.
But it's just so... beautiful.
*)
let mathop_do_once int_op float_op = function
| (LDouble v1, LDouble v2) -> LDouble (float_op v1 v2)
| (LDouble v1, LInt v2) -> LDouble (float_op v1 (float_of_int v2))
| (LInt v1, LDouble v2) -> LDouble (float_op (float_of_int v1) v2)
| (LInt v1, LInt v2) -> LInt (int_op v1 v2)
| _ -> invalid_arg "invalid arguments to mathematical operator"
let mathop_do_once_curried int_op float_op =
let f = mathop_do_once int_op float_op in
fun x -> fun y -> f (x, y)
let mathop_reduce fi ff init vs =
let curried = mathop_do_once_curried fi ff in
reduce init curried vs
let cast_int_to_double = function
| LInt x -> LDouble (float x)
| LDouble x -> LDouble x
| _ -> invalid_arg "can't cast_int_to_double!"
let add _ vs =
mathop_reduce (+) (+.) (LInt 0) vs
let sub _ = function
| LCons (x, LNil) -> ((mathop_do_once (-) (-.)) (LInt 0, x))
| LCons (x, rest) -> mathop_reduce (-) (-.) x rest
| _ -> invalid_arg "invalid argument list passed to (-)"
let mul _ vs =
mathop_reduce ( * ) ( *. ) (LInt 1) vs
let div _ vs =
let div_one = mathop_do_once ( / ) ( /. ) in
match vs with
(* (/ x) is equal to 1 / x *)
| LCons (x, LNil) -> div_one (LDouble 1., cast_int_to_double x)
| LCons (x, LCons (y, LNil)) -> div_one (cast_int_to_double x, y)
| _ -> invalid_arg "invalid argument list passed to (/)"
let rem _ = function
| LCons (x, LCons (y, LNil)) ->
mathop_do_once (mod) (mod_float) (cast_int_to_double x, cast_int_to_double y)
| _ -> invalid_arg "invalid argument list passed to (rem)"
let car _ = function
| LCons (a, _) -> a
| _ -> invalid_arg "car: non-cons"
let cdr _ = function
| LCons (_, d) -> d
| _ -> invalid_arg "cdr: non-cons"
let cons _ a b = LCons (a, b)
let lisp_list _ vs = vs
(* builtin function that updates an existing binding *)
let lisp_set env sym v =
match sym with
| LSymbol s -> Env.update env s v; v
| _ -> invalid_arg ("cannot set non-symbol " ^ dbg_print_one sym)
let lambda env = function
| LCons (l, body) ->
LLambda (env, l, body)
| args -> invalid_arg ("invalid args to fn! " ^ (dbg_print_one args))
let defn env = function
| LCons (LSymbol s, LCons (l, body)) ->
let f = LFunction (s, env, l, body) in
Env.set_global env s f; f
| args -> invalid_arg ("cannot define function! " ^ (dbg_print_one args))
let lambda_macro env = function
| LCons (l, body) -> LUnnamedMacro (env, l, body)
| args -> invalid_arg ("invalid args to fn-macro! " ^ (dbg_print_one args))
let defmacro env = function
| LCons (LSymbol s, LCons (l, body)) ->
let f = LMacro (s, env, l, body) in
Env.set_global env s f; f
| args -> invalid_arg ("cannot define macro! " ^ (dbg_print_one args))
let lisp_not _ = function
| LCons (LNil, LNil) -> LSymbol "t"
| _ -> LNil;;
(* This only creates a *local* binding, contained to the body given. *)
let bind_local env = function
| LCons (LSymbol s, LCons (v, body)) ->
let e = Env.new_lexical env in
Env.set_local e s (Eval.eval_one env v);
Eval.eval_body e body
| _ -> invalid_arg "invalid argument to bind-local"
(* special form that creates a global binding *)
let lisp_define env = function
| LCons (LSymbol s, LCons (v, LNil)) ->
let evaluated = Eval.eval_one env v in
Env.set_global env s evaluated;
evaluated
| _ -> invalid_arg "invalid args to def"
let lisp_if env = function
| LCons (cond, LCons (if_true, LNil)) ->
(match Eval.eval_one env cond with
| LNil -> LNil
| _ -> Eval.eval_one env if_true)
| LCons (cond, LCons (if_true, LCons (if_false, LNil))) ->
(match Eval.eval_one env cond with
| LNil -> Eval.eval_one env if_false
| _ -> Eval.eval_one env if_true)
| _ -> invalid_arg "invalid argument list passed to if!"
open Env;;
let bf s f = s, LBuiltinFunction (s, f)
let bf1 s f =
let aux e = function
| LCons (v, LNil) -> f e v
| _ -> invalid_arg ("invalid argument to " ^ s)
in bf s aux
let bf2 s f =
let aux e = function
| LCons (v1, LCons (v2, LNil)) -> f e v1 v2
| _ -> invalid_arg ("invalid argument to " ^ s)
in bf s aux
let sp s f = s, LBuiltinSpecial (s, f)
let sp1 s f =
let aux e = function
| LCons (v, LNil) -> f e v
| _ -> invalid_arg ("invalid argument to " ^ s)
in sp s aux
let sp2 s f =
let aux e = function
| LCons (v1, LCons (v2, LNil)) -> f e v1 v2
| _ -> invalid_arg ("invalid argument to " ^ s)
in sp s aux
let add_builtins bs =
List.iter (fun (s, f) -> set_default s f) bs
(*
(def defn
(fn-macro (name lm . body)
(list 'def name (cons 'fn (cons lm body)))))
(def defmacro
(fn-macro (name lm . body)
(list 'def name (cons 'fn-macro (cons lm body)))))
*)
let init_script =
"
(defmacro setq (sym val)
(list 'set (list 'quote sym) val))
(defmacro letfn (sym fun . body)
(cons 'let-one (cons sym (cons '() (cons (list 'setq sym fun) body)))))
(defn mapcar (f l)
(if l))
(defn filter (f l)
(letfn helper
(fn (l acc)
(if (nil? l) acc (helper (cdr l) (if (f (car l)) (cons (car l) acc) acc))))
(helper l '())))
";;
let init_default_env () =
add_builtins [
bf "+" add; bf "-" sub;
bf "*" mul; bf "/" div;
bf1 "car" car;
bf1 "cdr" cdr;
bf2 "cons" cons;
bf "rem" rem;
bf2 "set" lisp_set;
bf "list" lisp_list;
bf "nil?" lisp_not;
bf "not" lisp_not;
sp "fn" lambda;
sp "defn" defn;
sp "fn-macro" lambda_macro;
sp "defmacro" defmacro;
sp "let-one" bind_local;
sp "def" lisp_define;
sp1 "quote" (fun _ x -> x);
sp "if" lisp_if;
];
(*let () = add_builtin "print" lisp_prin *)
(* I know this looks insane. please trust me.
Idea: maybe put this in a file instead of putting
literally the entire standard library in a constant string
*)
ignore (Eval.eval_all default_env (read_from_str init_script));
()

1
lib/parser/ast.ml
View File

@@ -7,3 +7,4 @@ type lisp_ast =
| LString of string | LString of string
| LNil | LNil
| LCons of lisp_ast * lisp_ast | LCons of lisp_ast * lisp_ast

0
main.opam
View File

0
parser.opam
View File

9
parser/ast.ml
View File

@@ -1,9 +0,0 @@
type lisp_ast =
| LInt of int
| LDouble of float
| LSymbol of string
| LString of string
| LNil
| LCons of lisp_ast * lisp_ast

18
parser/ast.mli
View File

@@ -1,18 +0,0 @@
(** This is a simplified representation for the source code.
Note that this is different from the data representation used
during execution - that must naturally include things like
functions, structs, classes, etc.
This is used just to represent source code in an easy to process
manner. We translate this before actually using it.
The interpreter directly translates to its value type, the
compiler uses this to optimise and compile.
**)
type lisp_ast =
| LInt of int
| LDouble of float
| LSymbol of string
| LString of string
| LNil
| LCons of lisp_ast * lisp_ast

8
parser/dune
View File

@@ -1,8 +0,0 @@
(library
(name parser)
(public_name parser)
(modules parser lex parse ast)
)
(menhir (modules parse))
(ocamllex lex)

35
parser/lex.mll
View File

@@ -1,35 +0,0 @@
{
open Lexing
open Parse
exception SyntaxError of string
let strip_quotes s = String.sub s 1 (String.length s - 2);;
}
let digit = ['0'-'9']
let number_sign = '-' | '+'
let int = number_sign? digit+
let double = digit* '.' digit+ | digit+ '.' digit*
let white = [' ' '\t']+
let newline = '\r' | '\n' | "\r\n"
let sym_char = ['a'-'z' 'A'-'Z' '!' '\\' '+' '-' '*' '/' '_' '?']
let sym = sym_char sym_char*
let str = '"' [^'"']* '"'
rule read =
parse
| white { read lexbuf }
| newline { new_line lexbuf; read lexbuf}
| int { INT (int_of_string (Lexing.lexeme lexbuf))}
| double { DOUBLE (float_of_string (Lexing.lexeme lexbuf))}
| sym { SYM (Lexing.lexeme lexbuf)}
| str { STR (strip_quotes (Lexing.lexeme lexbuf))}
| '(' { LPAREN }
| ')' { RPAREN }
| '\'' { QUOTE }
| '.' { DOT }
| _ { raise (SyntaxError ("Unexpected char: " ^ Lexing.lexeme lexbuf))}
| eof { EOF }

36
parser/parse.mly
View File

@@ -1,36 +0,0 @@
%{
open Ast
%}
%token <int> INT
%token <float> DOUBLE
%token <string> SYM
%token <string> STR
%token LPAREN
%token RPAREN
%token QUOTE
%token DOT
%token EOF
%start <lisp_ast option> prog
%%
prog:
| EOF { None }
| e = expr { Some e }
;
expr:
| i = INT { LInt i }
| d = DOUBLE { LDouble d}
| s = SYM { LSymbol s }
| s = STR { LString (String.uppercase_ascii s) }
| LPAREN; l = lisp_list_rest { l }
| QUOTE; e = expr { LCons (LSymbol "quote", LCons (e, LNil)) }
;
lisp_list_rest:
| RPAREN { LNil }
| DOT; e = expr; RPAREN { e }
| e = expr; lr = lisp_list_rest { LCons (e, lr) }
;

16
parser/parser.ml
View File

@@ -1,16 +0,0 @@
let parse_one lb = Parse.prog (Lex.read) lb
let parse lb =
let rec helper () =
match parse_one lb with
| None -> []
| Some (t) -> t :: helper ()
in
helper ()
let parse_str s =
parse (Lexing.from_string s)
module Ast = Ast
module Parse = Parse