kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-11 13:55:55 +03:00
Code Issues Projects Releases Wiki Activity

Merge eval-ast and macro expansion into EVAL, add DEBUG-EVAL

Browse Source 
See issue #587.
* Merge eval-ast and eval into a single conditional.
* Expand macros during the apply phase, removing lots of duplicate
  tests, and increasing the overall consistency by allowing the macro
  to be computed instead of referenced by name (`((defmacro! cond
  (...)))` is currently illegal for example).
* Print "EVAL: $ast" at the top of EVAL if DEBUG-EVAL exists in the
  MAL environment.
* Remove macroexpand and quasiquoteexpand special forms.
* Use pattern-matching style in process/step*.txt.

Unresolved issues:
c.2: unable to reproduce with gcc 11.12.0.
elm: the directory is unchanged.
groovy: sometimes fail, but not on each rebuild.
nasm: fails some new soft tests, but the issue is unreproducible when
  running the interpreter manually.
objpascal: unreproducible with fpc 3.2.2.
ocaml: unreproducible with 4.11.1.
perl6: unreproducible with rakudo 2021.09.

Unrelated changes:
Reduce diff betweens steps.
Prevent defmacro! from mutating functions: c forth logo miniMAL vb.
dart: fix recent errors and warnings
ocaml: remove metadata from symbols.

Improve the logo implementation.
Encapsulate all representation in types.lg and env.lg, unwrap numbers.
Replace some manual iterations with logo control structures.
Reduce the diff between steps.
Use native iteration in env_get and env_map
Rewrite the reader with less temporary strings.
Reduce the number of temporary lists (for example, reverse iteration
with butlast requires O(n^2) allocations).
It seems possible to remove a few exceptions: GC settings
(Dockerfile), NO_SELF_HOSTING (IMPLS.yml) and step5_EXCLUDES
(Makefile.impls) .
This commit is contained in:
Nicolas Boulenguez 2022-01-10 00:15:40 +01:00 committed by Joel Martin
parent cb333f1387
commit 033892777a
636 changed files with 15876 additions and 20412 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

2
IMPLS.yml
View File

@ -49,7 +49,7 @@ IMPL:
- {IMPL: julia}
- {IMPL: kotlin}
- {IMPL: livescript}
- {IMPL: logo, NO_SELF_HOST: 1} # step4 timeout
- {IMPL: logo}
- {IMPL: lua}
- {IMPL: make, NO_SELF_HOST: 1} # step4 timeout
- {IMPL: mal, MAL_IMPL: js, BUILD_IMPL: js, NO_SELF_HOST: 1}

1
Makefile.impls
View File

@ -43,7 +43,6 @@ IMPLS = ada ada.2 awk bash basic bbc-basic c c.2 chuck clojure coffee common-lis
step5_EXCLUDES += bash # never completes at 10,000
step5_EXCLUDES += basic # too slow, and limited to ints of 2^16
step5_EXCLUDES += logo # too slow for 10,000
step5_EXCLUDES += make # no TCO capability (iteration or recursion)
step5_EXCLUDES += mal # host impl dependent
step5_EXCLUDES += matlab # never completes at 10,000

19
impls/ada.2/envs.adb
View File

@ -53,6 +53,25 @@ package body Envs is
return HM.Element (Position);
end Get;
function Get_Or_Nil (Env : Instance;
Key : Types.String_Ptr) return Types.T is
Position : HM.Cursor := Env.Data.Find (Key);
Ref : Link;
begin
if not HM.Has_Element (Position) then
Ref := Env.Outer;
loop
if Ref = null then
return Types.Nil;
end if;
Position := Ref.all.Data.Find (Key);
exit when HM.Has_Element (Position);
Ref := Ref.all.Outer;
end loop;
end if;
return HM.Element (Position);
end Get_Or_Nil;
procedure Keep_References (Object : in out Instance) is
begin
for Position in Object.Data.Iterate loop

3
impls/ada.2/envs.ads
View File

@ -27,6 +27,9 @@ package Envs is
function Get (Env : in Instance;
Key : in Types.String_Ptr) return Types.T;
function Get_Or_Nil (Env : Instance;
Key : Types.String_Ptr) return Types.T;
procedure Set (Env : in out Instance;
Key : in Types.T;
New_Item : in Types.T) with Inline;

11
impls/ada.2/step2_eval.adb
View File

@ -1,4 +1,3 @@
with Ada.Environment_Variables;
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Strings.Hash;
with Ada.Text_IO.Unbounded_IO;
@ -14,8 +13,6 @@ with Types.Strings;
procedure Step2_Eval is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use type Types.T;
use all type Types.Kind_Type;
@ -52,12 +49,8 @@ procedure Step2_Eval is
is
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
end if;
-- Ada.Text_IO.Put ("EVAL: ");
-- Print (Ast);
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>

7
impls/ada.2/step3_env.adb
View File

@ -1,4 +1,3 @@
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Envs;
@ -13,7 +12,7 @@ with Types.Strings;
procedure Step3_Env is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -45,8 +44,7 @@ procedure Step3_Env is
is
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -209,6 +207,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

25
impls/ada.2/step4_if_fn_do.adb
View File

@ -1,4 +1,3 @@
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -15,7 +14,7 @@ with Types.Strings;
procedure Step4_If_Fn_Do is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -47,8 +46,7 @@ procedure Step4_If_Fn_Do is
is
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -81,17 +79,13 @@ procedure Step4_If_Fn_Do is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
return Eval (Ast.Sequence.all.Data (3), Env);
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
return Eval (Ast.Sequence.all.Data (4), Env);
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
return Eval (Ast.Sequence.all.Data (3), Env);
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
return Eval (Ast.Sequence.all.Data (4), Env);
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -251,6 +245,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

29
impls/ada.2/step5_tco.adb
View File

@ -1,4 +1,3 @@
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -15,7 +14,7 @@ with Types.Strings;
procedure Step5_Tco is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -56,8 +55,7 @@ procedure Step5_Tco is
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -90,19 +88,15 @@ procedure Step5_Tco is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -284,6 +278,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

29
impls/ada.2/step6_file.adb
View File

@ -1,5 +1,4 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -16,7 +15,7 @@ with Types.Strings;
procedure Step6_File is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -60,8 +59,7 @@ procedure Step6_File is
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -94,19 +92,15 @@ procedure Step6_File is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -310,6 +304,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

32
impls/ada.2/step7_quote.adb
View File

@ -1,5 +1,4 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -16,7 +15,7 @@ with Types.Strings;
procedure Step7_Quote is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -62,8 +61,7 @@ procedure Step7_Quote is
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -96,19 +94,15 @@ procedure Step7_Quote is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -167,9 +161,6 @@ procedure Step7_Quote is
Ast => Ast.Sequence.all.Data (3),
Env => Env));
end;
elsif First.Str.all = "quasiquoteexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all.Data (2));
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Ast := Quasiquote (Ast.Sequence.all.Data (2));
@ -379,6 +370,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

66
impls/ada.2/step8_macros.adb
View File

@ -1,5 +1,4 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -16,7 +15,7 @@ with Types.Strings;
procedure Step8_Macros is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -59,12 +58,10 @@ procedure Step8_Macros is
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -97,19 +94,15 @@ procedure Step8_Macros is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -183,14 +176,6 @@ procedure Step8_Macros is
Ast => Ast.Sequence.all.Data (3),
Env => Env));
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Str.all = "quasiquoteexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all.Data (2));
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Ast := Quasiquote (Ast.Sequence.all.Data (2));
@ -217,24 +202,10 @@ procedure Step8_Macros is
case First.Kind is
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Fn.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
end if;
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
when Types.Kind_Function =>
null;
when others =>
@ -260,11 +231,7 @@ procedure Step8_Macros is
end;
exception
when Err.Error =>
if Macroexpanding then
Err.Add_Trace_Line ("macroexpand", Ast);
else
Err.Add_Trace_Line ("eval", Ast);
end if;
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
@ -434,6 +401,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

66
impls/ada.2/step9_try.adb
View File

@ -1,5 +1,4 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -16,7 +15,7 @@ with Types.Strings;
procedure Step9_Try is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -59,12 +58,10 @@ procedure Step9_Try is
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -97,19 +94,15 @@ procedure Step9_Try is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -183,14 +176,6 @@ procedure Step9_Try is
Ast => Ast.Sequence.all.Data (3),
Env => Env));
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Str.all = "quasiquoteexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all.Data (2));
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Ast := Quasiquote (Ast.Sequence.all.Data (2));
@ -247,24 +232,10 @@ procedure Step9_Try is
case First.Kind is
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Fn.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
end if;
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
when Types.Kind_Function =>
null;
when others =>
@ -290,11 +261,7 @@ procedure Step9_Try is
end;
exception
when Err.Error =>
if Macroexpanding then
Err.Add_Trace_Line ("macroexpand", Ast);
else
Err.Add_Trace_Line ("eval", Ast);
end if;
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
@ -464,6 +431,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

66
impls/ada.2/stepa_mal.adb
View File

@ -1,5 +1,4 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Text_IO.Unbounded_IO;
with Core;
@ -17,7 +16,7 @@ with Types.Strings;
procedure StepA_Mal is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Types.String_Ptr := Types.Strings.Alloc ("DEBUG-EVAL");
use type Types.T;
use all type Types.Kind_Type;
@ -60,12 +59,10 @@ procedure StepA_Mal is
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
Ada.Text_IO.New_Line;
if Types.To_Boolean (Env.all.Get_Or_Nil (Dbgeval)) then
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
Envs.Dump_Stack (Env.all);
@ -98,19 +95,15 @@ procedure StepA_Mal is
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
if Types.To_Boolean (Eval (Ast.Sequence.all.Data (2), Env)) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Types.Nil;
else
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
@ -184,14 +177,6 @@ procedure StepA_Mal is
Ast => Ast.Sequence.all.Data (3),
Env => Env));
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Str.all = "quasiquoteexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all.Data (2));
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Ast := Quasiquote (Ast.Sequence.all.Data (2));
@ -248,24 +233,10 @@ procedure StepA_Mal is
case First.Kind is
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Fn.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
end if;
Ast := First.Fn.all.Apply
(Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
-- Then evaluate the result with TCO.
goto Restart;
when Types.Kind_Function =>
null;
when others =>
@ -296,11 +267,7 @@ procedure StepA_Mal is
end;
exception
when Err.Error =>
if Macroexpanding then
Err.Add_Trace_Line ("macroexpand", Ast);
else
Err.Add_Trace_Line ("eval", Ast);
end if;
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
@ -472,6 +439,7 @@ begin
-- Collect garbage.
Err.Data := Types.Nil;
Repl.all.Keep;
Dbgeval.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;

6
impls/ada.2/types.adb
View File

@ -55,4 +55,10 @@ package body Types is
end case;
end Keep;
function To_Boolean (Form : T) return Boolean is
(case Form.Kind is
when Kind_Nil => False,
when Kind_Boolean => Form.Ada_Boolean,
when others => True);
end Types;

2
impls/ada.2/types.ads
View File

@ -83,6 +83,8 @@ package Types is
Nil : constant T := (Kind => Kind_Nil);
function To_Boolean (Form : T) return Boolean with Inline;
procedure Keep (Object : in T) with Inline;
type T_Array is array (Positive range <>) of T;

48
impls/ada/step2_eval.adb
View File

@ -109,6 +109,19 @@ procedure Step2_Eval is
end Call_Eval;
begin
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : String_Mal_Hash.Map)
return Mal_Handle is
First_Elem : Mal_Handle;
Ast : Mal_Handle renames Param; -- Historic
begin
if Debug then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
case Deref (Ast).Sym_Type is
@ -129,27 +142,10 @@ procedure Step2_Eval is
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : String_Mal_Hash.Map)
return Mal_Handle is
First_Elem : Mal_Handle;
begin
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
declare
Evaled_H, First_Param : Mal_Handle;
@ -169,12 +165,10 @@ procedure Step2_Eval is
return Call_Func (Deref_Func (First_Param).all, Cdr (Evaled_List));
end;
else -- Not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

68
impls/ada/step3_env.adb
View File

@ -65,8 +65,6 @@ procedure Step3_Env is
function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle)
return Types.Mal_Handle;
Debug : Boolean := False;
function Read (Param : String) return Types.Mal_Handle is
begin
@ -112,6 +110,31 @@ procedure Step3_Env is
end Call_Eval;
begin
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
Ast : Mal_Handle renames Param; -- Historic
begin
declare
M : Mal_Handle;
B : Boolean;
begin
M := Envs.Get (Env, "DEBUG-EVAL");
case Deref (M).Sym_Type is
when Bool => B := Deref_Bool (M).Get_Bool;
when Nil => B := False;
when others => B := True;
end case;
if B then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
case Deref (Ast).Sym_Type is
@ -132,27 +155,10 @@ procedure Step3_Env is
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
First_Elem : Mal_Handle;
begin
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
declare
Evaled_H, First_Param, Rest_List : Mal_Handle;
@ -184,12 +190,10 @@ procedure Step3_Env is
end;
else -- Not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;
@ -244,12 +248,6 @@ begin
-- as we know Eval will be in scope for the lifetime of the program.
Eval_Callback.Eval := Eval'Unrestricted_Access;
if Ada.Command_Line.Argument_Count > 0 then
if Ada.Command_Line.Argument (1) = "-d" then
Debug := True;
end if;
end if;
Repl_Env := Envs.New_Env;
Init (Repl_Env);

52
impls/ada/step4_if_fn_do.adb
View File

@ -102,6 +102,23 @@ procedure Step4_If_Fn_Do is
end Call_Eval;
begin
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) return Mal_Handle is
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
Ast : Mal_Handle renames Param; -- Historic
begin
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
case Deref (Ast).Sym_Type is
@ -122,27 +139,10 @@ procedure Step4_If_Fn_Do is
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
end Eval_Ast;
function Eval (Param : Mal_Handle; Env : Envs.Env_Handle) return Mal_Handle is
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
begin
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -234,12 +234,10 @@ procedure Step4_If_Fn_Do is
end if;
else -- Not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

68
impls/ada/step5_tco.adb
View File

@ -71,6 +71,31 @@ procedure Step5_TCO is
end Call_Eval;
begin
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
return Mal_Handle is
Param : Mal_Handle;
Env : Envs.Env_Handle;
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
Ast : Mal_Handle renames Param; -- Historic
begin
Param := AParam;
Env := AnEnv;
<<Tail_Call_Opt>>
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
case Deref (Ast).Sym_Type is
@ -91,35 +116,10 @@ procedure Step5_TCO is
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
end Eval_Ast;
function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
return Mal_Handle is
Param : Mal_Handle;
Env : Envs.Env_Handle;
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
begin
Param := AParam;
Env := AnEnv;
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -278,12 +278,10 @@ procedure Step5_TCO is
end if;
else -- Not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

70
impls/ada/step6_file.adb
View File

@ -74,6 +74,33 @@ procedure Step6_File is
end Call_Eval;
begin
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
return Mal_Handle is
Param : Mal_Handle;
Env : Envs.Env_Handle;
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
Ast : Mal_Handle renames Param; -- Historic
begin
Param := AParam;
Env := AnEnv;
<<Tail_Call_Opt>>
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
case Deref (Ast).Sym_Type is
@ -94,35 +121,10 @@ procedure Step6_File is
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
end Eval_Ast;
function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
return Mal_Handle is
Param : Mal_Handle;
Env : Envs.Env_Handle;
First_Param, Rest_Params : Mal_Handle;
Rest_List, Param_List : List_Mal_Type;
begin
Param := AParam;
Env := AnEnv;
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -281,12 +283,10 @@ procedure Step6_File is
end if;
else -- not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

76
impls/ada/step7_quote.adb
View File

@ -71,33 +71,8 @@ procedure Step7_Quote is
end Call_Eval;
begin
case Deref (Ast).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Ast;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is
@ -190,12 +165,34 @@ procedure Step7_Quote is
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref (Param).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Param).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Param;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -305,11 +302,6 @@ procedure Step7_Quote is
return Car (Rest_List);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then
return Quasi_Quote_Processing (Car (Rest_List));
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquote" then
@ -370,12 +362,10 @@ procedure Step7_Quote is
end if;
else -- not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

155
impls/ada/step8_macros.adb
View File

@ -59,52 +59,6 @@ procedure Step8_Macros is
end Def_Macro;
function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
Res : Mal_Handle;
E : Envs.Env_Handle;
LMT : List_Mal_Type;
LP : Lambda_Ptr;
begin
Res := Ast;
loop
if Deref (Res).Sym_Type /= List then
exit;
end if;
LMT := Deref_List (Res).all;
-- Get the macro in the list from the env
-- or return null if not applicable.
LP := Get_Macro (Res, Env);
exit when LP = null or else not LP.Get_Is_Macro;
declare
Fn_List : Mal_Handle := Cdr (LMT);
Params : List_Mal_Type;
begin
E := Envs.New_Env (LP.Get_Env);
Params := Deref_List (LP.Get_Params).all;
if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
Res := Eval (LP.Get_Expr, E);
end if;
end;
end loop;
return Res;
end Macro_Expand;
function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
Res : Boolean;
begin
@ -137,33 +91,8 @@ procedure Step8_Macros is
end Call_Eval;
begin
case Deref (Ast).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Ast;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is
@ -256,18 +185,34 @@ procedure Step8_Macros is
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
Param := Macro_Expand (Param, Env);
if Debug then
Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref (Param).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Param).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Param;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -286,9 +231,6 @@ procedure Step8_Macros is
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "defmacro!" then
return Def_Macro (Rest_List, Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "macroexpand" then
return Macro_Expand (Car (Rest_List), Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "let*" then
declare
@ -383,11 +325,6 @@ procedure Step8_Macros is
return Car (Rest_List);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then
return Quasi_Quote_Processing (Car (Rest_List));
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquote" then
@ -397,18 +334,10 @@ procedure Step8_Macros is
else
-- The APPLY section.
declare
Evaled_H : Mal_Handle;
begin
Evaled_H := Eval_Ast (Param, Env);
Param_List := Deref_List (Evaled_H).all;
First_Param := Car (Param_List);
Rest_Params := Cdr (Param_List);
Rest_List := Deref_List (Rest_Params).all;
First_Param := Eval (First_Param, Env);
if Deref (First_Param).Sym_Type = Func then
Rest_Params := Eval_Ast (Rest_Params, Env);
return Call_Func (Deref_Func (First_Param).all, Rest_Params);
elsif Deref (First_Param).Sym_Type = Lambda then
declare
@ -421,6 +350,16 @@ procedure Step8_Macros is
begin
L := Deref_Lambda (First_Param).all;
if L.Get_Is_Macro then
-- Apply to *unevaluated* arguments
Param := L.Apply (Rest_Params);
-- then EVAL the result.
goto Tail_Call_Opt;
end if;
Rest_Params := Eval_Ast (Rest_Params, Env);
E := Envs.New_Env (L.Get_Env);
Param_Names := Deref_List (L.Get_Params).all;
@ -444,16 +383,12 @@ procedure Step8_Macros is
raise Runtime_Exception with "Deref called on non-Func/Lambda";
end if;
end;
end if;
else -- not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

155
impls/ada/step9_try.adb
View File

@ -59,52 +59,6 @@ procedure Step9_Try is
end Def_Macro;
function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
Res : Mal_Handle;
E : Envs.Env_Handle;
LMT : List_Mal_Type;
LP : Lambda_Ptr;
begin
Res := Ast;
loop
if Deref (Res).Sym_Type /= List then
exit;
end if;
LMT := Deref_List (Res).all;
-- Get the macro in the list from the env
-- or return null if not applicable.
LP := Get_Macro (Res, Env);
exit when LP = null or else not LP.Get_Is_Macro;
declare
Fn_List : Mal_Handle := Cdr (LMT);
Params : List_Mal_Type;
begin
E := Envs.New_Env (LP.Get_Env);
Params := Deref_List (LP.Get_Params).all;
if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
Res := Eval (LP.Get_Expr, E);
end if;
end;
end loop;
return Res;
end Macro_Expand;
function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
Res : Boolean;
begin
@ -137,33 +91,8 @@ procedure Step9_Try is
end Call_Eval;
begin
case Deref (Ast).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Ast;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is
@ -282,18 +211,34 @@ procedure Step9_Try is
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
Param := Macro_Expand (Param, Env);
if Debug then
Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref (Param).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Param).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Param;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -312,9 +257,6 @@ procedure Step9_Try is
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "defmacro!" then
return Def_Macro (Rest_List, Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "macroexpand" then
return Macro_Expand (Car (Rest_List), Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "let*" then
declare
@ -409,11 +351,6 @@ procedure Step9_Try is
return Car (Rest_List);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then
return Quasi_Quote_Processing (Car (Rest_List));
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquote" then
@ -450,18 +387,10 @@ procedure Step9_Try is
else
-- The APPLY section.
declare
Evaled_H : Mal_Handle;
begin
Evaled_H := Eval_Ast (Param, Env);
Param_List := Deref_List (Evaled_H).all;
First_Param := Car (Param_List);
Rest_Params := Cdr (Param_List);
Rest_List := Deref_List (Rest_Params).all;
First_Param := Eval (First_Param, Env);
if Deref (First_Param).Sym_Type = Func then
Rest_Params := Eval_Ast (Rest_Params, Env);
return Call_Func (Deref_Func (First_Param).all, Rest_Params);
elsif Deref (First_Param).Sym_Type = Lambda then
declare
@ -474,6 +403,16 @@ procedure Step9_Try is
begin
L := Deref_Lambda (First_Param).all;
if L.Get_Is_Macro then
-- Apply to *unevaluated* arguments
Param := L.Apply (Rest_Params);
-- then EVAL the result.
goto Tail_Call_Opt;
end if;
Rest_Params := Eval_Ast (Rest_Params, Env);
E := Envs.New_Env (L.Get_Env);
Param_Names := Deref_List (L.Get_Params).all;
@ -497,16 +436,12 @@ procedure Step9_Try is
raise Runtime_Exception with "Deref called on non-Func/Lambda";
end if;
end;
end if;
else -- not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

156
impls/ada/stepa_mal.adb
View File

@ -59,53 +59,6 @@ procedure StepA_Mal is
end Def_Macro;
function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
return Mal_Handle is
Res : Mal_Handle;
E : Envs.Env_Handle;
LMT : List_Mal_Type;
LP : Lambda_Ptr;
begin
Res := Ast;
loop
if Deref (Res).Sym_Type /= List then
exit;
end if;
LMT := Deref_List (Res).all;
-- Get the macro in the list from the env
-- or return null if not applicable.
LP := Get_Macro (Res, Env);
exit when LP = null or else not LP.Get_Is_Macro;
declare
Fn_List : Mal_Handle := Cdr (LMT);
Params : List_Mal_Type;
begin
E := Envs.New_Env (LP.Get_Env);
Params := Deref_List (LP.Get_Params).all;
if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
Res := Eval (LP.Get_Expr, E);
end if;
end;
end loop;
return Res;
end Macro_Expand;
function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
Res : Boolean;
begin
@ -138,33 +91,8 @@ procedure StepA_Mal is
end Call_Eval;
begin
case Deref (Ast).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Ast;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
when others => return Ast;
end case;
pragma Assert (Deref (Ast).Sym_Type = List); -- list, map or vector
return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
end Eval_Ast;
function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is
@ -283,18 +211,34 @@ procedure StepA_Mal is
<<Tail_Call_Opt>>
if Debug then
Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
end if;
begin
if Eval_As_Boolean (Envs.Get (Env, "DEBUG-EVAL")) then
Ada.Text_IO.Put_Line ("EVAL: " & Deref (Param).To_String);
end if;
exception
when Envs.Not_Found => null;
end;
Param := Macro_Expand (Param, Env);
if Debug then
Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
end if;
if Deref (Param).Sym_Type = List and then
Deref_List (Param).Get_List_Type = List_List then
case Deref (Param).Sym_Type is
when Sym =>
declare
Sym : Mal_String := Deref_Sym (Param).Get_Sym;
begin
-- if keyword, return it. Otherwise look it up in the environment.
if Sym(1) = ':' then
return Param;
else
return Envs.Get (Env, Sym);
end if;
exception
when Envs.Not_Found =>
raise Envs.Not_Found with ("'" & Sym & "' not found");
end;
when List =>
case Deref_List (Param).Get_List_Type is
when Hashed_List | Vector_List =>
return Eval_Ast (Param, Env);
when List_List =>
Param_List := Deref_List (Param).all;
@ -313,9 +257,6 @@ procedure StepA_Mal is
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "defmacro!" then
return Def_Macro (Rest_List, Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "macroexpand" then
return Macro_Expand (Car (Rest_List), Env);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "let*" then
declare
@ -410,11 +351,6 @@ procedure StepA_Mal is
return Car (Rest_List);
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then
return Quasi_Quote_Processing (Car (Rest_List));
elsif Deref (First_Param).Sym_Type = Sym and then
Deref_Sym (First_Param).Get_Sym = "quasiquote" then
@ -451,18 +387,10 @@ procedure StepA_Mal is
else
-- The APPLY section.
declare
Evaled_H : Mal_Handle;
begin
Evaled_H := Eval_Ast (Param, Env);
Param_List := Deref_List (Evaled_H).all;
First_Param := Car (Param_List);
Rest_Params := Cdr (Param_List);
Rest_List := Deref_List (Rest_Params).all;
First_Param := Eval (First_Param, Env);
if Deref (First_Param).Sym_Type = Func then
Rest_Params := Eval_Ast (Rest_Params, Env);
return Call_Func (Deref_Func (First_Param).all, Rest_Params);
elsif Deref (First_Param).Sym_Type = Lambda then
declare
@ -475,6 +403,16 @@ procedure StepA_Mal is
begin
L := Deref_Lambda (First_Param).all;
if L.Get_Is_Macro then
-- Apply to *unevaluated* arguments
Param := L.Apply (Rest_Params);
-- then EVAL the result.
goto Tail_Call_Opt;
end if;
Rest_Params := Eval_Ast (Rest_Params, Env);
E := Envs.New_Env (L.Get_Env);
Param_Names := Deref_List (L.Get_Params).all;
@ -498,16 +436,12 @@ procedure StepA_Mal is
raise Runtime_Exception with "Deref called on non-Func/Lambda";
end if;
end;
end if;
else -- not a List_List
return Eval_Ast (Param, Env);
end if;
end case;
when others => -- not a list, map, symbol or vector
return Param;
end case;
end Eval;

69
impls/ada/types.adb
View File

@ -141,40 +141,6 @@ package body Types is
return To_Str (T, Print_Readably);
end To_String;
function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean is
L : List_Mal_Type;
First_Elem, Func : Mal_Handle;
begin
if T.Sym_Type /= List then
return False;
end if;
L := List_Mal_Type (T);
if Is_Null (L) then
return False;
end if;
First_Elem := Car (L);
if Deref (First_Elem).Sym_Type /= Sym then
return False;
end if;
Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym);
if Deref (Func).Sym_Type /= Lambda then
return False;
end if;
return Deref_Lambda (Func).Get_Is_Macro;
exception
when Envs.Not_Found => return False;
end Is_Macro_Call;
-- A helper function that just view converts the smart pointer.
function Deref (S : Mal_Handle) return Mal_Ptr is
begin
@ -1072,41 +1038,6 @@ package body Types is
end Apply;
function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr is
L : List_Mal_Type;
First_Elem, Func : Mal_Handle;
begin
if Deref (T).Sym_Type /= List then
return null;
end if;
L := Deref_List (T).all;
if Is_Null (L) then
return null;
end if;
First_Elem := Car (L);
if Deref (First_Elem).Sym_Type /= Sym then
return null;
end if;
Func := Envs.Get (Env, Deref_Sym (First_Elem).Get_Sym);
if Deref (Func).Sym_Type /= Lambda then
return null;
end if;
return Deref_Lambda (Func);
exception
when Envs.Not_Found => return null;
end Get_Macro;
overriding function To_Str
(T : Lambda_Mal_Type; Print_Readably : Boolean := True)
return Mal_String is

4
impls/ada/types.ads
View File

@ -51,8 +51,6 @@ package Types is
function To_String (T : Mal_Type'Class; Print_Readably : Boolean := True)
return Mal_String;
function Is_Macro_Call (T : Mal_Type'Class; Env : Envs.Env_Handle) return Boolean;
type Mal_Ptr is access all Mal_Type'Class;
-- A helper function that just view converts the smart pointer to
@ -297,8 +295,6 @@ package Types is
type Lambda_Ptr is access all Lambda_Mal_Type;
function Get_Macro (T : Mal_Handle; Env : Envs.Env_Handle) return Lambda_Ptr;
function Deref_Lambda (SP : Mal_Handle) return Lambda_Ptr;
generic

52
impls/awk/step2_eval.awk
View File

@ -8,18 +8,20 @@ function READ(str)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
if (ast in env) {
return types_addref(env[ast])
}
return "!\"'" substr(ast, 2) "' not found"
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -30,7 +32,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -44,29 +49,48 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
{
if (ast !~ /^\(/) {
# print "EVAL: " printer_pr_str(ast, 1)
switch (ast) {
case /^'/: # symbol
if (ast in env) {
ret = types_addref(env[ast])
} else {
ret = "!\"'" substr(ast, 2) "' not found"
}
types_release(ast)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
return ret
case /^[^(]/: # not a list
types_release(ast)
return ast
}
idx = substr(ast, 2)
if (types_heap[idx]["len"] == 0) {
return ast
}
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
if (f ~ /^&/) {
f_idx = substr(f, 2)
ret = @f_idx(idx)

71
impls/awk/step3_env.awk
View File

@ -9,19 +9,20 @@ function READ(str)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -32,7 +33,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -46,9 +50,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -125,11 +126,39 @@ function EVAL_let(ast, env, idx, params, params_idx, params_len, new_env, i,
function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
{
env_addref(env)
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
if (types_heap[idx]["len"] == 0) {
@ -142,6 +171,12 @@ function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
case "'let*":
return EVAL_let(ast, env)
default:
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
@ -149,13 +184,13 @@ function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
if (f ~ /^&/) {
f_idx = substr(f, 2)
f_idx = substr(f, 2)
switch (f) {
case /^&/:
ret = @f_idx(idx)
types_release(new_ast)
return ret
} else {
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
}

64
impls/awk/step4_if_fn_do.awk
View File

@ -10,19 +10,20 @@ function READ(str)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -33,7 +34,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -47,9 +51,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -225,11 +226,39 @@ function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx
function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
{
env_addref(env)
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
if (types_heap[idx]["len"] == 0) {
@ -248,6 +277,12 @@ function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
case "'fn*":
return EVAL_fn(ast, env)
default:
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
@ -255,7 +290,6 @@ function EVAL(ast, env, new_ast, ret, idx, f, f_idx)
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:

71
impls/awk/step5_tco.awk
View File

@ -10,19 +10,20 @@ function READ(str)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -33,7 +34,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -47,9 +51,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -214,15 +215,43 @@ function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx
return "$" f_idx
}
function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env)
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
@ -256,6 +285,12 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
case "'fn*":
return EVAL_fn(ast, env)
default:
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
@ -263,7 +298,6 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
@ -273,6 +307,7 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^&/:
@ -281,7 +316,9 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

71
impls/awk/step6_file.awk
View File

@ -10,19 +10,20 @@ function READ(str)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -33,7 +34,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -47,9 +51,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -214,15 +215,43 @@ function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx
return "$" f_idx
}
function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env)
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
@ -256,6 +285,12 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
case "'fn*":
return EVAL_fn(ast, env)
default:
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
@ -263,7 +298,6 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
@ -273,6 +307,7 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^&/:
@ -281,7 +316,9 @@ function EVAL(ast, env, new_ast, ret, idx, len, f, f_idx, ret_env)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

80
impls/awk/step7_quote.awk
View File

@ -89,19 +89,20 @@ function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous)
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -112,7 +113,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -126,9 +130,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -293,15 +294,43 @@ function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx
return "$" f_idx
}
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env)
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
@ -329,15 +358,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
types_release(ast)
env_release(env)
return body
case "'quasiquoteexpand":
env_release(env)
if (len != 2) {
types_release(ast)
return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
return quasiquote(body)
case "'quasiquote":
if (len != 2) {
types_release(ast)
@ -368,6 +388,12 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
case "'fn*":
return EVAL_fn(ast, env)
default:
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
@ -375,7 +401,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
return new_ast
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
@ -385,6 +410,7 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^&/:
@ -393,7 +419,9 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

169
impls/awk/step8_macros.awk
View File

@ -88,52 +88,21 @@ function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous)
return "(" new_idx
}
function is_macro_call(ast, env, idx, len, sym, f)
{
if (ast !~ /^\(/) return 0
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) return 0
sym = types_heap[idx][0]
if (sym !~ /^'/) return 0
f = env_get(env, sym)
return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"]
}
function macroexpand(ast, env, idx, f_idx, new_env)
{
while (is_macro_call(ast, env)) {
idx = substr(ast, 2)
f_idx = substr(env_get(env, types_heap[idx][0]), 2)
new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (new_env ~ /^!/) {
return new_env
}
types_addref(ast = types_heap[f_idx]["body"])
ast = EVAL(ast, new_env)
env_release(new_env)
if (ast ~ /^!/) {
return ast
}
}
return ast
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -144,7 +113,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -158,9 +130,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -368,33 +337,50 @@ function EVAL_fn(ast, env, idx, params, params_idx, params_len, i, sym, f_idx
return "$" f_idx
}
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret_env)
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
}
if (types_heap[substr(ast, 2)]["len"] == 0) {
env_release(env)
return ast
}
ast = macroexpand(ast, env)
if (ast ~ /^!/) {
env_release(env)
return ast
}
if (ast !~ /^\(/) {
ret = eval_ast(ast, env)
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) {
env_release(env)
return ast
}
switch (types_heap[idx][0]) {
case "'def!":
return EVAL_def(ast, env)
@ -415,15 +401,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
types_release(ast)
env_release(env)
return body
case "'quasiquoteexpand":
env_release(env)
if (len != 2) {
types_release(ast)
return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
return quasiquote(body)
case "'quasiquote":
if (len != 2) {
types_release(ast)
@ -440,17 +417,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
continue
case "'defmacro!":
return EVAL_defmacro(ast, env)
case "'macroexpand":
if (len != 2) {
types_release(ast)
env_release(env)
return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
ret = macroexpand(body, env)
env_release(env)
return ret
case "'do":
ast = EVAL_do(ast, env)
if (ast ~ /^!/) {
@ -467,32 +433,61 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_env)
case "'fn*":
return EVAL_fn(ast, env)
default:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
if (types_heap[f_idx]["is_macro"]) {
idx = substr(ast, 2)
ret = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (ret ~ /^!/) {
types_release(f)
types_release(env)
return ret
}
ast = EVAL(types_addref(types_heap[f_idx]["body"]), ret)
types_release(ret)
types_release(f)
continue
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
if (env ~ /^!/) {
types_release(new_ast)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^&/:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
ret = @f_idx(idx)
types_release(new_ast)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

167
impls/awk/step9_try.awk
View File

@ -88,52 +88,21 @@ function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous)
return "(" new_idx
}
function is_macro_call(ast, env, idx, len, sym, f)
{
if (ast !~ /^\(/) return 0
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) return 0
sym = types_heap[idx][0]
if (sym !~ /^'/) return 0
f = env_get(env, sym)
return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"]
}
function macroexpand(ast, env, idx, f_idx, new_env)
{
while (is_macro_call(ast, env)) {
idx = substr(ast, 2)
f_idx = substr(env_get(env, types_heap[idx][0]), 2)
new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (new_env ~ /^!/) {
return new_env
}
types_addref(ast = types_heap[f_idx]["body"])
ast = EVAL(ast, new_env)
env_release(new_env)
if (ast ~ /^!/) {
return ast
}
}
return ast
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -144,7 +113,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -158,9 +130,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -426,29 +395,46 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
}
if (types_heap[substr(ast, 2)]["len"] == 0) {
env_release(env)
return ast
}
ast = macroexpand(ast, env)
if (ast ~ /^!/) {
env_release(env)
return ast
}
if (ast !~ /^\(/) {
ret = eval_ast(ast, env)
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) {
env_release(env)
return ast
}
switch (types_heap[idx][0]) {
case "'def!":
return EVAL_def(ast, env)
@ -469,15 +455,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
types_release(ast)
env_release(env)
return body
case "'quasiquoteexpand":
env_release(env)
if (len != 2) {
types_release(ast)
return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
return quasiquote(body)
case "'quasiquote":
if (len != 2) {
types_release(ast)
@ -494,17 +471,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
continue
case "'defmacro!":
return EVAL_defmacro(ast, env)
case "'macroexpand":
if (len != 2) {
types_release(ast)
env_release(env)
return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
ret = macroexpand(body, env)
env_release(env)
return ret
case "'try*":
ret = EVAL_try(ast, env, ret_body, ret_env)
if (ret != "") {
@ -529,32 +495,61 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
case "'fn*":
return EVAL_fn(ast, env)
default:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
if (types_heap[f_idx]["is_macro"]) {
idx = substr(ast, 2)
ret = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (ret ~ /^!/) {
types_release(f)
types_release(env)
return ret
}
ast = EVAL(types_addref(types_heap[f_idx]["body"]), ret)
types_release(ret)
types_release(f)
continue
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
if (env ~ /^!/) {
types_release(new_ast)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^&/:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
ret = @f_idx(idx)
types_release(new_ast)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

168
impls/awk/stepA_mal.awk
View File

@ -88,52 +88,21 @@ function quasiquote(ast, new_idx, ret, ast_idx, elt_i, elt, previous)
return "(" new_idx
}
function is_macro_call(ast, env, idx, len, sym, f)
{
if (ast !~ /^\(/) return 0
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) return 0
sym = types_heap[idx][0]
if (sym !~ /^'/) return 0
f = env_get(env, sym)
return f ~ /^\$/ && types_heap[substr(f, 2)]["is_macro"]
}
function macroexpand(ast, env, idx, f_idx, new_env)
{
while (is_macro_call(ast, env)) {
idx = substr(ast, 2)
f_idx = substr(env_get(env, types_heap[idx][0]), 2)
new_env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (new_env ~ /^!/) {
return new_env
}
types_addref(ast = types_heap[f_idx]["body"])
ast = EVAL(ast, new_env)
env_release(new_env)
if (ast ~ /^!/) {
return ast
}
}
return ast
}
function eval_ast(ast, env, i, idx, len, new_idx, ret)
# This function has two distinct purposes.
# non empty list: a0 a1 .. an -> list: nil (eval a1) .. (eval an)
# vector: a0 a1 .. an -> vector: (eval a0) (eval a1) .. (eval an)
{
switch (ast) {
case /^'/:
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
return ret
case /^[([]/:
idx = substr(ast, 2)
len = types_heap[idx]["len"]
new_idx = types_allocate()
for (i = 0; i < len; ++i) {
if (ast ~ /^\(/) {
types_heap[new_idx][0] = "#nil"
i = 1
} else {
i = 0
}
for (; i < len; ++i) {
ret = EVAL(types_addref(types_heap[idx][i]), env)
if (ret ~ /^!/) {
types_heap[new_idx]["len"] = i
@ -144,7 +113,10 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
types_heap[new_idx]["len"] = len
return substr(ast, 1, 1) new_idx
case /^\{/:
}
function eval_map(ast, env, i, idx, new_idx, ret)
{
idx = substr(ast, 2)
new_idx = types_allocate()
for (i in types_heap[idx]) {
@ -158,9 +130,6 @@ function eval_ast(ast, env, i, idx, len, new_idx, ret)
}
}
return "{" new_idx
default:
return ast
}
}
function EVAL_def(ast, env, idx, sym, ret, len)
@ -426,29 +395,46 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
{
env_addref(env)
for (;;) {
if (ast !~ /^\(/) {
switch (env_get(env, "'DEBUG-EVAL")) {
case /^!/:
case "#nil":
case "#false":
break
default:
print "EVAL: " printer_pr_str(ast, 1)
}
switch (ast) {
case /^'/: # symbol
ret = env_get(env, ast)
if (ret !~ /^!/) {
types_addref(ret)
}
types_release(ast)
env_release(env)
return ret
case /^\[/: # vector
ret = eval_ast(ast, env)
types_release(ast)
env_release(env)
return ret
}
if (types_heap[substr(ast, 2)]["len"] == 0) {
env_release(env)
return ast
}
ast = macroexpand(ast, env)
if (ast ~ /^!/) {
env_release(env)
return ast
}
if (ast !~ /^\(/) {
ret = eval_ast(ast, env)
case /^\{/: # map
ret = eval_map(ast, env)
types_release(ast)
env_release(env)
return ret
case /^[^(]/: # not a list
types_release(ast)
env_release(env)
return ast
}
idx = substr(ast, 2)
len = types_heap[idx]["len"]
if (len == 0) {
env_release(env)
return ast
}
switch (types_heap[idx][0]) {
case "'def!":
return EVAL_def(ast, env)
@ -469,15 +455,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
types_release(ast)
env_release(env)
return body
case "'quasiquoteexpand":
env_release(env)
if (len != 2) {
types_release(ast)
return "!\"Invalid argument length for 'quasiquoteexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
return quasiquote(body)
case "'quasiquote":
if (len != 2) {
types_release(ast)
@ -494,17 +471,6 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
continue
case "'defmacro!":
return EVAL_defmacro(ast, env)
case "'macroexpand":
if (len != 2) {
types_release(ast)
env_release(env)
return "!\"Invalid argument length for 'macroexpand'. Expects exactly 1 argument, supplied " (len - 1) "."
}
types_addref(body = types_heap[idx][1])
types_release(ast)
ret = macroexpand(body, env)
env_release(env)
return ret
case "'try*":
ret = EVAL_try(ast, env, ret_body, ret_env)
if (ret != "") {
@ -529,34 +495,64 @@ function EVAL(ast, env, body, new_ast, ret, idx, len, f, f_idx, ret_body, ret
case "'fn*":
return EVAL_fn(ast, env)
default:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
f = EVAL(types_addref(types_heap[idx][0]), env)
if (f ~ /^!/) {
types_release(ast)
env_release(env)
return f
}
idx = substr(new_ast, 2)
f = types_heap[idx][0]
f_idx = substr(f, 2)
switch (f) {
case /^\$/:
if (types_heap[f_idx]["is_macro"]) {
idx = substr(ast, 2)
ret = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
types_release(ast)
if (ret ~ /^!/) {
types_release(f)
types_release(env)
return ret
}
ast = EVAL(types_addref(types_heap[f_idx]["body"]), ret)
types_release(ret)
types_release(f)
continue
}
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
env = env_new(types_heap[f_idx]["env"], types_heap[f_idx]["params"], idx)
if (env ~ /^!/) {
types_release(new_ast)
return env
}
types_addref(ast = types_heap[f_idx]["body"])
types_release(f)
types_release(new_ast)
continue
case /^%/:
f_idx = types_heap[f_idx]["func"]
types_release(f)
case /^&/:
new_ast = eval_ast(ast, env)
types_release(ast)
env_release(env)
if (new_ast ~ /^!/) {
return new_ast
}
idx = substr(new_ast, 2)
ret = @f_idx(idx)
types_release(new_ast)
return ret
default:
types_release(new_ast)
return "!\"First element of list must be function, supplied " types_typename(f) "."
ret = "!\"First element of list must be function, supplied " types_typename(f) "."
types_release(f)
return ret
}
}
}

30
impls/bash/step2_eval.sh
View File

@ -10,7 +10,7 @@ READ () {
}
# eval
EVAL_AST () {
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
@ -18,11 +18,13 @@ EVAL_AST () {
symbol)
local val="${ANON["${ast}"]}"
eval r="\${${env}["${val}"]}"
[ "${r}" ] || _error "'${val}' not found" ;;
[ "${r}" ] || _error "'${val}' not found"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -32,27 +34,17 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
if [[ "${ot}" != "list" ]]; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
EVAL_AST "${ast}" "${env}"
_map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && return 1
local el="${r}"
_first "${el}"; local f="${r}"

38
impls/bash/step3_env.sh
View File

@ -11,18 +11,28 @@ READ () {
}
# eval
EVAL_AST () {
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -32,22 +42,12 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
if [[ "${ot}" != "list" ]]; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
@ -71,7 +71,7 @@ EVAL () {
done
EVAL "${a2}" "${let_env}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) _map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${r}"

40
impls/bash/step4_if_fn_do.sh
View File

@ -12,18 +12,28 @@ READ () {
}
# eval
EVAL_AST () {
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -33,22 +43,12 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
if [[ "${ot}" != "list" ]]; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
@ -73,7 +73,7 @@ EVAL () {
EVAL "${a2}" "${let_env}"
return ;;
do) _rest "${ast}"
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${r}"
return ;;
@ -95,7 +95,7 @@ EVAL () {
fn__STAR__) _function "ENV \"${env}\" \"${a1}\" \"\${@}\"; \
EVAL \"${a2}\" \"\${r}\""
return ;;
*) EVAL_AST "${ast}" "${env}"
*) _map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"

43
impls/bash/step5_tco.sh
View File

@ -12,18 +12,30 @@ READ () {
}
# eval
EVAL_AST () {
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -33,23 +45,12 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
if [[ "${ot}" != "list" ]]; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
@ -77,7 +78,7 @@ EVAL () {
;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -104,7 +105,7 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) _map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"

43
impls/bash/step6_file.sh
View File

@ -12,18 +12,30 @@ READ () {
}
# eval
EVAL_AST () {
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -33,23 +45,12 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
if [[ "${ot}" != "list" ]]; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
@ -77,7 +78,7 @@ EVAL () {
;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -104,7 +105,7 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) _map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"

45
impls/bash/step7_quote.sh
View File

@ -55,18 +55,30 @@ qqIter () {
fi
}
EVAL_AST () {
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -76,22 +88,12 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
_empty? "${ast}" && r="${ast}" && return
@ -120,9 +122,6 @@ EVAL () {
quote)
r="${a1}"
return ;;
quasiquoteexpand)
QUASIQUOTE "${a1}"
return ;;
quasiquote)
QUASIQUOTE "${a1}"
ast="${r}"
@ -130,7 +129,7 @@ EVAL () {
;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -157,7 +156,7 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) _map_with_type _list EVAL "${ast}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"

101
impls/bash/step8_macros.sh
View File

@ -55,45 +55,30 @@ qqIter () {
fi
}
IS_MACRO_CALL () {
if ! _list? "${1}"; then return 1; fi
_nth "${1}" 0; local a0="${r}"
if _symbol? "${a0}"; then
ENV_FIND "${2}" "${a0}"
if [[ "${r}" ]]; then
ENV_GET "${2}" "${a0}"
[ "${ANON["${r}_ismacro_"]}" ]
return $?
fi
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
return 1
}
MACROEXPAND () {
local ast="${1}" env="${2}"
while IS_MACRO_CALL "${ast}" "${env}"; do
_nth "${ast}" 0; local a0="${r}"
ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}"
_rest "${ast}"
${mac%%@*} ${ANON["${r}"]}
ast="${r}"
done
r="${ast}"
}
EVAL_AST () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -103,30 +88,14 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
MACROEXPAND "${ast}" "${env}"
ast="${r}"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
_empty? "${ast}" && r="${ast}" && return
_nth "${ast}" 0; local a0="${r}"
@ -153,9 +122,6 @@ EVAL () {
quote)
r="${a1}"
return ;;
quasiquoteexpand)
QUASIQUOTE "${a1}"
return ;;
quasiquote)
QUASIQUOTE "${a1}"
ast="${r}"
@ -170,12 +136,9 @@ EVAL () {
ANON["${r}_ismacro_"]="yes"
ENV_SET "${env}" "${a1}" "${r}"
return ;;
macroexpand)
MACROEXPAND "${a1}" "${env}"
return ;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -202,11 +165,27 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) EVAL "${a0}" "${env}"
[[ "${__ERROR}" ]] && return 1
local f="${r}"
_rest "${ast}"
# Should cause no error as ast is not empty.
local args="${r}"
if [ "${ANON["${f}_ismacro_"]}" ]; then
f="${ANON["${f}"]}"
${f%%@*} ${ANON["${args}"]}
ast="${r}"
continue
fi
f="${ANON["${f}"]}"
_map_with_type _list EVAL "${args}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"
_rest "${el}"; local args="${ANON["${r}"]}"
args="${ANON["${r}"]}"
#echo "invoke: [${f}] ${args}"
if [[ "${f//@/ }" != "${f}" ]]; then
set -- ${f//@/ }

101
impls/bash/step9_try.sh
View File

@ -55,45 +55,30 @@ qqIter () {
fi
}
IS_MACRO_CALL () {
if ! _list? "${1}"; then return 1; fi
_nth "${1}" 0; local a0="${r}"
if _symbol? "${a0}"; then
ENV_FIND "${2}" "${a0}"
if [[ "${r}" ]]; then
ENV_GET "${2}" "${a0}"
[ "${ANON["${r}_ismacro_"]}" ]
return $?
fi
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
return 1
}
MACROEXPAND () {
local ast="${1}" env="${2}"
while IS_MACRO_CALL "${ast}" "${env}"; do
_nth "${ast}" 0; local a0="${r}"
ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}"
_rest "${ast}"
${mac%%@*} ${ANON["${r}"]}
ast="${r}"
done
r="${ast}"
}
EVAL_AST () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -103,30 +88,14 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
MACROEXPAND "${ast}" "${env}"
ast="${r}"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
_empty? "${ast}" && r="${ast}" && return
_nth "${ast}" 0; local a0="${r}"
@ -153,9 +122,6 @@ EVAL () {
quote)
r="${a1}"
return ;;
quasiquoteexpand)
QUASIQUOTE "${a1}"
return ;;
quasiquote)
QUASIQUOTE "${a1}"
ast="${r}"
@ -170,9 +136,6 @@ EVAL () {
ANON["${r}_ismacro_"]="yes"
ENV_SET "${env}" "${a1}" "${r}"
return ;;
macroexpand)
MACROEXPAND "${a1}" "${env}"
return ;;
try__STAR__) EVAL "${a1}" "${env}"
[[ -z "${__ERROR}" ]] && return
_nth "${a2}" 0; local a20="${r}"
@ -188,7 +151,7 @@ EVAL () {
return ;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -215,11 +178,27 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) EVAL "${a0}" "${env}"
[[ "${__ERROR}" ]] && return 1
local f="${r}"
_rest "${ast}"
# Should cause no error as ast is not empty.
local args="${r}"
if [ "${ANON["${f}_ismacro_"]}" ]; then
f="${ANON["${f}"]}"
${f%%@*} ${ANON["${args}"]}
ast="${r}"
continue
fi
f="${ANON["${f}"]}"
_map_with_type _list EVAL "${args}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"
_rest "${el}"; local args="${ANON["${r}"]}"
args="${ANON["${r}"]}"
#echo "invoke: [${f}] ${args}"
if [[ "${f//@/ }" != "${f}" ]]; then
set -- ${f//@/ }

101
impls/bash/stepA_mal.sh
View File

@ -55,45 +55,30 @@ qqIter () {
fi
}
IS_MACRO_CALL () {
if ! _list? "${1}"; then return 1; fi
_nth "${1}" 0; local a0="${r}"
if _symbol? "${a0}"; then
ENV_FIND "${2}" "${a0}"
if [[ "${r}" ]]; then
ENV_GET "${2}" "${a0}"
[ "${ANON["${r}_ismacro_"]}" ]
return $?
fi
_symbol DEBUG-EVAL; debug_eval="$r"
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
ENV_GET "$env" "$debug_eval"
if [ -n "$__ERROR" ]; then
__ERROR=
elif [ "$r" != "$__false" -a "$r" != "$__nil" ]; then
_pr_str "$ast" yes; echo "EVAL: $r / $env"
fi
return 1
}
MACROEXPAND () {
local ast="${1}" env="${2}"
while IS_MACRO_CALL "${ast}" "${env}"; do
_nth "${ast}" 0; local a0="${r}"
ENV_GET "${env}" "${a0}"; local mac="${ANON["${r}"]}"
_rest "${ast}"
${mac%%@*} ${ANON["${r}"]}
ast="${r}"
done
r="${ast}"
}
EVAL_AST () {
local ast="${1}" env="${2}"
#_pr_str "${ast}"; echo "EVAL_AST '${ast}:${r} / ${env}'"
_obj_type "${ast}"; local ot="${r}"
case "${ot}" in
symbol)
ENV_GET "${env}" "${ast}"
return ;;
list)
_map_with_type _list EVAL "${ast}" "${env}" ;;
;;
vector)
_map_with_type _vector EVAL "${ast}" "${env}" ;;
_map_with_type _vector EVAL "${ast}" "${env}"
return ;;
hash_map)
local res="" key= val="" hm="${ANON["${ast}"]}"
_hash_map; local new_hm="${r}"
@ -103,30 +88,14 @@ EVAL_AST () {
EVAL "${val}" "${env}"
_assoc! "${new_hm}" "${key}" "${r}"
done
r="${new_hm}" ;;
r="${new_hm}"
return ;;
*)
r="${ast}" ;;
r="${ast}"
return ;;
esac
}
EVAL () {
local ast="${1}" env="${2}"
while true; do
r=
[[ "${__ERROR}" ]] && return 1
#_pr_str "${ast}"; echo "EVAL '${r} / ${env}'"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
# apply list
MACROEXPAND "${ast}" "${env}"
ast="${r}"
if ! _list? "${ast}"; then
EVAL_AST "${ast}" "${env}"
return
fi
_empty? "${ast}" && r="${ast}" && return
_nth "${ast}" 0; local a0="${r}"
@ -153,9 +122,6 @@ EVAL () {
quote)
r="${a1}"
return ;;
quasiquoteexpand)
QUASIQUOTE "${a1}"
return ;;
quasiquote)
QUASIQUOTE "${a1}"
ast="${r}"
@ -170,9 +136,6 @@ EVAL () {
ANON["${r}_ismacro_"]="yes"
ENV_SET "${env}" "${a1}" "${r}"
return ;;
macroexpand)
MACROEXPAND "${a1}" "${env}"
return ;;
sh__STAR__) EVAL "${a1}" "${env}"
local output=""
local line=""
@ -198,7 +161,7 @@ EVAL () {
return ;;
do) _count "${ast}"
_slice "${ast}" 1 $(( ${r} - 2 ))
EVAL_AST "${r}" "${env}"
_map_with_type _list EVAL "${r}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
_last "${ast}"
ast="${r}"
@ -225,11 +188,27 @@ EVAL () {
EVAL \"${a2}\" \"\${r}\"" \
"${a2}" "${env}" "${a1}"
return ;;
*) EVAL_AST "${ast}" "${env}"
*) EVAL "${a0}" "${env}"
[[ "${__ERROR}" ]] && return 1
local f="${r}"
_rest "${ast}"
# Should cause no error as ast is not empty.
local args="${r}"
if [ "${ANON["${f}_ismacro_"]}" ]; then
f="${ANON["${f}"]}"
${f%%@*} ${ANON["${args}"]}
ast="${r}"
continue
fi
f="${ANON["${f}"]}"
_map_with_type _list EVAL "${args}" "${env}"
[[ "${__ERROR}" ]] && r= && return 1
local el="${r}"
_first "${el}"; local f="${ANON["${r}"]}"
_rest "${el}"; local args="${ANON["${r}"]}"
args="${ANON["${r}"]}"
#echo "invoke: [${f}] ${args}"
if [[ "${f//@/ }" != "${f}" ]]; then
set -- ${f//@/ }

23
impls/bbc-basic/env.bas
View File

@ -1,39 +1,36 @@
REM > env library for mal in BBC BASIC
DEF FNnew_env(outer%, binds%, exprs%)
LOCAL env%
LOCAL env%, key$
env% = FNalloc_environment(outer%)
WHILE NOT FNis_empty(binds%)
IF FNunbox_symbol(FNfirst(binds%)) = "&" THEN
PROCenv_set(env%, FNnth(binds%, 1), FNas_list(exprs%))
key$ = FNunbox_symbol(FNfirst(binds%))
IF key$ = "&" THEN
PROCenv_set(env%, FNunbox_symbol(FNnth(binds%, 1)), FNas_list(exprs%))
binds% = FNempty
ELSE
PROCenv_set(env%, FNfirst(binds%), FNfirst(exprs%))
PROCenv_set(env%, key$, FNfirst(exprs%))
binds% = FNrest(binds%) : exprs% = FNrest(exprs%)
ENDIF
ENDWHILE
=env%
DEF PROCenv_set(env%, keysym%, val%)
DEF PROCenv_set(env%, key$, val%)
LOCAL data%
data% = FNenvironment_data(env%)
data% = FNhashmap_set(data%, FNunbox_symbol(keysym%), val%)
data% = FNhashmap_set(data%, key$, val%)
PROCenvironment_set_data(env%, data%)
ENDPROC
DEF FNenv_find(env%, keysym%)
LOCAL val%, outer%, key$
key$ = FNunbox_symbol(keysym%)
DEF FNenv_find(env%, key$)
WHILE NOT FNis_nil(env%)
IF FNhashmap_contains(FNenvironment_data(env%), key$) THEN =env%
env% = FNenvironment_outer(env%)
ENDWHILE
=FNnil
DEF FNenv_get(env%, keysym%)
LOCAL key$
env% = FNenv_find(env%, keysym%)
key$ = FNunbox_symbol(keysym%)
DEF FNenv_get(env%, key$)
env% = FNenv_find(env%, key$)
IF FNis_nil(env%) THEN ERROR &40E80922, "'"+key$+"' not found"
=FNhashmap_get(FNenvironment_data(env%), key$)

48
impls/bbc-basic/step2_eval.bas
View File

@ -30,10 +30,28 @@ DEF FNREAD(a$)
=FNread_str(FNalloc_string(a$))
DEF FNEVAL(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
LOCAL car%, val%, key$
REM PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
IF FNis_symbol(ast%) THEN
val% = FNhashmap_get(env%, FNunbox_symbol(ast%))
IF val% = FNnil THEN ERROR &40E80922, "Symbol not in environment"
=val%
ENDIF
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
ast% = FNeval_ast(ast%, env%)
=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%))
car% = FNEVAL(FNfirst(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, FNeval_ast(FNrest(ast%), env%))
=FNcore_call(FNunbox_corefn(car%), FNeval_ast(FNrest(ast%), env%))
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -42,30 +60,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN
val% = FNhashmap_get(env%, FNunbox_symbol(ast%))
IF val% = FNnil THEN ERROR &40E80922, "Symbol not in environment"
=val%
ENDIF
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
REM Call a core function, taking the function number and a mal list of
REM objects to pass as arguments.

84
impls/bbc-basic/step3_env.bas
View File

@ -9,10 +9,10 @@ PROCtypes_init
REM These correspond with the CASE statement in FNcore_call
repl_env% = FNalloc_environment(FNnil)
PROCenv_set(repl_env%, FNalloc_symbol("+"), FNalloc_corefn(0))
PROCenv_set(repl_env%, FNalloc_symbol("-"), FNalloc_corefn(1))
PROCenv_set(repl_env%, FNalloc_symbol("*"), FNalloc_corefn(2))
PROCenv_set(repl_env%, FNalloc_symbol("/"), FNalloc_corefn(3))
PROCenv_set(repl_env%, "+", FNalloc_corefn(0))
PROCenv_set(repl_env%, "-", FNalloc_corefn(1))
PROCenv_set(repl_env%, "*", FNalloc_corefn(2))
PROCenv_set(repl_env%, "/", FNalloc_corefn(3))
sav% = FNgc_save
REPEAT
@ -31,31 +31,53 @@ DEF FNREAD(a$)
=FNread_str(FNalloc_string(a$))
DEF FNEVAL(ast%, env%)
LOCAL car%
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
LOCAL car%, val%, bindings%, key$
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
car% = FNfirst(ast%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
LOCAL val%
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
=val%
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
LOCAL bindings%
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
=FNEVAL(FNnth(ast%, 2), env%)
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
=FNEVAL(FNnth(ast%, 2), env%)
OTHERWISE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
ast% = FNeval_ast(ast%, env%)
=FNcore_call(FNunbox_corefn(FNfirst(ast%)), FNrest(ast%))
REM This is the "apply" part.
ast% = FNeval_ast(FNrest(ast%), env%)
=FNcore_call(FNunbox_corefn(car%), ast%)
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -64,26 +86,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
REM Call a core function, taking the function number and a mal list of
REM objects to pass as arguments.

110
impls/bbc-basic/step4_if_fn_do.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -41,53 +41,71 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
LOCAL car%, val%, bindings%, key$
PROCgc_keep_only2(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
car% = FNfirst(ast%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
LOCAL val%
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
=val%
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
LOCAL bindings%
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
=FNEVAL(FNnth(ast%, 2), env%)
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
=FNEVAL(FNnth(ast%, 2), env%)
WHEN "do"
LOCAL val%
ast% = FNeval_ast(FNrest(ast%), env%)
REPEAT
val% = FNfirst(ast%)
ast% = FNrest(ast%)
UNTIL FNis_empty(ast%)
=val%
WHILE TRUE
ast% = FNrest(ast%)
IF FNis_empty(ast%) THEN = val%
val% = FNEVAL(FNfirst(ast%), env%)
ENDWHILE
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
=FNEVAL(FNnth(ast%, 2), env%)
ENDIF
IF FNcount(ast%) = 3 THEN =FNnil
=FNEVAL(FNnth(ast%, 3), env%)
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN =FNEVAL(FNnth(ast%, 2), env%)
IF FNcount(ast%) = 3 THEN =FNnil
=FNEVAL(FNnth(ast%, 3), env%)
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
OTHERWISE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
=FNEVAL(FNfn_ast(car%), env%)
ENDIF
REM This is the "apply" part.
ast% = FNeval_ast(FNrest(ast%), env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
=FNEVAL(FNfn_ast(car%), env%)
ENDIF
ERROR &40E80918, "Not a function"
@ -98,26 +116,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
REM Local Variables:
REM indent-tabs-mode: nil

92
impls/bbc-basic/step5_tco.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -40,30 +40,47 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -75,35 +92,34 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNeval_ast(FNrest(ast%), env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
UNTIL FALSE
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -112,26 +128,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
REM Local Variables:
REM indent-tabs-mode: nil

96
impls/bbc-basic/step6_file.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -30,9 +30,9 @@ UNTIL form$ = ""
argv% = FNget_argv
IF FNis_empty(argv%) THEN
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
PROCenv_set(repl_env%, "*ARGV*", FNempty)
ELSE
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%))
val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
END
ENDIF
@ -58,30 +58,47 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -93,35 +110,34 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNeval_ast(FNrest(ast%), env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
UNTIL FALSE
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -130,26 +146,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
DEF FNget_argv
PROCgc_enter

100
impls/bbc-basic/step7_quote.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -30,9 +30,9 @@ UNTIL form$ = ""
argv% = FNget_argv
IF FNis_empty(argv%) THEN
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
PROCenv_set(repl_env%, "*ARGV*", FNempty)
ELSE
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%))
val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
END
ENDIF
@ -86,30 +86,47 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -121,42 +138,39 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
WHEN "quote"
=FNnth(ast%, 1)
WHEN "quasiquoteexpand"
= FNquasiquote(FNnth(ast%, 1))
WHEN "quasiquote"
ast% = FNquasiquote(FNnth(ast%, 1))
REM Loop round for tail-call optimisation
GOTO 31416
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNeval_ast(FNrest(ast%), env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
UNTIL FALSE
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -165,26 +179,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
DEF FNget_argv
PROCgc_enter

132
impls/bbc-basic/step8_macros.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -31,9 +31,9 @@ UNTIL form$ = ""
argv% = FNget_argv
IF FNis_empty(argv%) THEN
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
PROCenv_set(repl_env%, "*ARGV*", FNempty)
ELSE
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%))
val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
END
ENDIF
@ -82,63 +82,57 @@ DEF FNquasiquote(ast%)
ENDIF
=ast%
DEF FNis_macro_call(ast%, env%)
LOCAL car%, val%
IF NOT FNis_list(ast%) THEN =FALSE
car% = FNfirst(ast%)
IF NOT FNis_symbol(car%) THEN =FALSE
IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE
val% = FNenv_get(env%, car%)
=FNis_macro(val%)
DEF FNmacroexpand(ast%, env%)
LOCAL mac%, macenv%, macast%
WHILE FNis_macro_call(ast%, env%)
REM PRINT "expanded ";FNpr_str(ast%, TRUE);
mac% = FNenv_get(env%, FNfirst(ast%))
macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%))
macast% = FNfn_ast(mac%)
ast% = FNEVAL(macast%, macenv%)
REM PRINT " to ";FNpr_str(ast%, TRUE)
ENDWHILE
=ast%
DEF FNEVAL(ast%, env%)
PROCgc_enter
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
ast% = FNmacroexpand(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "defmacro!"
val% = FNEVAL(FNnth(ast%, 2), env%)
IF FNis_fn(val%) THEN val% = FNas_macro(val%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -150,44 +144,44 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
WHEN "quote"
=FNnth(ast%, 1)
WHEN "quasiquoteexpand"
= FNquasiquote(FNnth(ast%, 1))
WHEN "quasiquote"
ast% = FNquasiquote(FNnth(ast%, 1))
REM Loop round for tail-call optimisation
WHEN "macroexpand"
=FNmacroexpand(FNnth(ast%, 1), env%)
GOTO 31416
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNrest(ast%)
IF FNis_macro(car%) THEN
ast% = FNEVAL(FNfn_ast(car%), FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%))
GOTO 31416
ENDIF
UNTIL FALSE
ast% = FNeval_ast(ast%, env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -196,26 +190,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
DEF FNget_argv
PROCgc_enter

132
impls/bbc-basic/step9_try.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -31,9 +31,9 @@ UNTIL form$ = ""
argv% = FNget_argv
IF FNis_empty(argv%) THEN
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
PROCenv_set(repl_env%, "*ARGV*", FNempty)
ELSE
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%))
val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
END
ENDIF
@ -82,27 +82,6 @@ DEF FNquasiquote(ast%)
ENDIF
=ast%
DEF FNis_macro_call(ast%, env%)
LOCAL car%, val%
IF NOT FNis_list(ast%) THEN =FALSE
car% = FNfirst(ast%)
IF NOT FNis_symbol(car%) THEN =FALSE
IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE
val% = FNenv_get(env%, car%)
=FNis_macro(val%)
DEF FNmacroexpand(ast%, env%)
LOCAL mac%, macenv%, macast%
WHILE FNis_macro_call(ast%, env%)
REM PRINT "expanded ";FNpr_str(ast%, TRUE);
mac% = FNenv_get(env%, FNfirst(ast%))
macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%))
macast% = FNfn_ast(mac%)
ast% = FNEVAL(macast%, macenv%)
REM PRINT " to ";FNpr_str(ast%, TRUE)
ENDWHILE
=ast%
DEF FNtry_catch(ast%, env%)
LOCAL is_error%, ret%
REM If there's no 'catch*' clause then we just evaluate the 'try*'.
@ -150,37 +129,52 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
ast% = FNmacroexpand(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "defmacro!"
val% = FNEVAL(FNnth(ast%, 2), env%)
IF FNis_fn(val%) THEN val% = FNas_macro(val%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -192,46 +186,46 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
WHEN "quote"
=FNnth(ast%, 1)
WHEN "quasiquoteexpand"
= FNquasiquote(FNnth(ast%, 1))
WHEN "quasiquote"
ast% = FNquasiquote(FNnth(ast%, 1))
REM Loop round for tail-call optimisation
WHEN "macroexpand"
=FNmacroexpand(FNnth(ast%, 1), env%)
GOTO 31416
WHEN "try*"
=FNtry_catch(ast%, env%)
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNrest(ast%)
IF FNis_macro(car%) THEN
ast% = FNEVAL(FNfn_ast(car%), FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%))
GOTO 31416
ENDIF
UNTIL FALSE
ast% = FNeval_ast(ast%, env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -240,26 +234,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
DEF FNget_argv
PROCgc_enter

132
impls/bbc-basic/stepA_mal.bas
View File

@ -13,7 +13,7 @@ PROCcore_ns : REM This sets the data pointer
REPEAT
READ sym$, i%
IF sym$ <> "" THEN
PROCenv_set(repl_env%, FNalloc_symbol(sym$), FNalloc_corefn(i%))
PROCenv_set(repl_env%, sym$, FNalloc_corefn(i%))
ENDIF
UNTIL sym$ = ""
@ -32,9 +32,9 @@ UNTIL form$ = ""
argv% = FNget_argv
IF FNis_empty(argv%) THEN
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNempty)
PROCenv_set(repl_env%, "*ARGV*", FNempty)
ELSE
PROCenv_set(repl_env%, FNalloc_symbol("*ARGV*"), FNrest(argv%))
PROCenv_set(repl_env%, "*ARGV*", FNrest(argv%))
val$ = FNrep("(load-file " + FNunbox_string(FNpr_str(FNfirst(argv%), TRUE)) + ")")
END
ENDIF
@ -84,27 +84,6 @@ DEF FNquasiquote(ast%)
ENDIF
=ast%
DEF FNis_macro_call(ast%, env%)
LOCAL car%, val%
IF NOT FNis_list(ast%) THEN =FALSE
car% = FNfirst(ast%)
IF NOT FNis_symbol(car%) THEN =FALSE
IF FNis_nil(FNenv_find(env%, car%)) THEN =FALSE
val% = FNenv_get(env%, car%)
=FNis_macro(val%)
DEF FNmacroexpand(ast%, env%)
LOCAL mac%, macenv%, macast%
WHILE FNis_macro_call(ast%, env%)
REM PRINT "expanded ";FNpr_str(ast%, TRUE);
mac% = FNenv_get(env%, FNfirst(ast%))
macenv% = FNnew_env(FNfn_env(mac%), FNfn_params(mac%), FNrest(ast%))
macast% = FNfn_ast(mac%)
ast% = FNEVAL(macast%, macenv%)
REM PRINT " to ";FNpr_str(ast%, TRUE)
ENDWHILE
=ast%
DEF FNtry_catch(ast%, env%)
LOCAL is_error%, ret%
REM If there's no 'catch*' clause then we just evaluate the 'try*'.
@ -152,37 +131,52 @@ DEF FNEVAL(ast%, env%)
=FNgc_exit(FNEVAL_(ast%, env%))
DEF FNEVAL_(ast%, env%)
LOCAL car%, specialform%, val%, bindings%
REPEAT
LOCAL car%, val%, bindings%, key$
31416 REM tail call optimization loop
PROCgc_keep_only2(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
val% = FNenv_find(env%, "DEBUG-EVAL")
IF NOT FNis_nil(val%) THEN
IF FNis_truish(FNenv_get(val%, "DEBUG-EVAL")) THEN
PRINT "EVAL: " + FNunbox_string(FNpr_str(ast%, TRUE))
ENDIF
ENDIF
IF FNis_symbol(ast%) THEN =FNenv_get(env%, FNunbox_symbol(ast%))
IF FNis_hashmap(ast%) THEN
val% = FNempty_hashmap
bindings% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(bindings%)
key$ = FNunbox_string(FNfirst(bindings%))
val% = FNhashmap_set(val%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
bindings% = FNrest(bindings%)
ENDWHILE
=val%
ENDIF
IF NOT FNis_seq(ast%) THEN =ast%
IF FNis_empty(ast%) THEN =ast%
ast% = FNmacroexpand(ast%, env%)
IF NOT FNis_list(ast%) THEN =FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
specialform% = FALSE
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(FNEVAL(car%, env%), FNeval_ast(FNrest(ast%), env%))
IF FNis_symbol(car%) THEN
specialform% = TRUE
CASE FNunbox_symbol(car%) OF
key$ = FNunbox_symbol(car%)
CASE key$ OF
REM Special forms
WHEN "def!"
val% = FNEVAL(FNnth(ast%, 2), env%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "defmacro!"
val% = FNEVAL(FNnth(ast%, 2), env%)
IF FNis_fn(val%) THEN val% = FNas_macro(val%)
PROCenv_set(env%, FNnth(ast%, 1), val%)
PROCenv_set(env%, FNunbox_symbol(FNnth(ast%, 1)), val%)
=val%
WHEN "let*"
env% = FNalloc_environment(env%)
bindings% = FNnth(ast%, 1)
WHILE NOT FNis_empty(bindings%)
PROCenv_set(env%, FNfirst(bindings%), FNEVAL(FNnth(bindings%, 1), env%))
PROCenv_set(env%, FNunbox_symbol(FNfirst(bindings%)), FNEVAL(FNnth(bindings%, 1), env%))
bindings% = FNrest(FNrest(bindings%))
ENDWHILE
ast% = FNnth(ast%, 2)
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "do"
REM The guide has us call FNeval_ast on the sub-list that excludes
REM the last element of ast%, but that's a bit painful without
@ -194,46 +188,46 @@ DEF FNEVAL_(ast%, env%)
ast% = FNrest(ast%)
ENDWHILE
ast% = FNfirst(ast%)
GOTO 31416
WHEN "if"
IF FNis_truish(FNEVAL(FNnth(ast%, 1), env%)) THEN
ast% = FNnth(ast%, 2)
ELSE
IF FNcount(ast%) = 3 THEN =FNnil ELSE ast% = FNnth(ast%, 3)
IF FNcount(ast%) = 3 THEN =FNnil
ast% = FNnth(ast%, 3)
ENDIF
REM Loop round for tail-call optimisation.
GOTO 31416
WHEN "fn*"
=FNalloc_fn(FNnth(ast%, 2), FNnth(ast%, 1), env%)
WHEN "quote"
=FNnth(ast%, 1)
WHEN "quasiquoteexpand"
= FNquasiquote(FNnth(ast%, 1))
WHEN "quasiquote"
ast% = FNquasiquote(FNnth(ast%, 1))
REM Loop round for tail-call optimisation
WHEN "macroexpand"
=FNmacroexpand(FNnth(ast%, 1), env%)
GOTO 31416
WHEN "try*"
=FNtry_catch(ast%, env%)
OTHERWISE
specialform% = FALSE
car% = FNenv_get(env%, key$)
ENDCASE
ELSE
car% = FNEVAL(car%, env%)
ENDIF
IF NOT specialform% THEN
REM This is the "apply" part.
ast% = FNeval_ast(ast%, env%)
car% = FNfirst(ast%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), FNrest(ast%))
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), FNrest(ast%))
ast% = FNfn_ast(car%)
REM Loop round for tail-call optimisation.
ELSE
ERROR &40E80918, "Not a function"
ENDIF
REM This is the "apply" part.
ast% = FNrest(ast%)
IF FNis_macro(car%) THEN
ast% = FNEVAL(FNfn_ast(car%), FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%))
GOTO 31416
ENDIF
UNTIL FALSE
ast% = FNeval_ast(ast%, env%)
IF FNis_corefn(car%) THEN
=FNcore_call(FNunbox_corefn(car%), ast%)
ENDIF
IF FNis_fn(car%) THEN
env% = FNnew_env(FNfn_env(car%), FNfn_params(car%), ast%)
ast% = FNfn_ast(car%)
GOTO 31416
ENDIF
ERROR &40E80918, "Not a function"
DEF FNPRINT(a%)
=FNunbox_string(FNpr_str(a%, TRUE))
@ -242,26 +236,8 @@ DEF FNrep(a$)
=FNPRINT(FNEVAL(FNREAD(a$), repl_env%))
DEF FNeval_ast(ast%, env%)
LOCAL val%, car%, cdr%, map%, keys%, key$
IF FNis_symbol(ast%) THEN =FNenv_get(env%, ast%)
IF FNis_seq(ast%) THEN
IF FNis_empty(ast%) THEN =ast%
car% = FNEVAL(FNfirst(ast%), env%)
cdr% = FNeval_ast(FNrest(ast%), env%)
IF FNis_vector(ast%) THEN =FNalloc_vector_pair(car%, cdr%)
=FNalloc_pair(car%, cdr%)
ENDIF
IF FNis_hashmap(ast%) THEN
map% = FNempty_hashmap
keys% = FNhashmap_keys(ast%)
WHILE NOT FNis_empty(keys%)
key$ = FNunbox_string(FNfirst(keys%))
map% = FNhashmap_set(map%, key$, FNEVAL(FNhashmap_get(ast%, key$), env%))
keys% = FNrest(keys%)
ENDWHILE
=map%
ENDIF
=ast%
=FNalloc_pair(FNEVAL(FNfirst(ast%), env%), FNeval_ast(FNrest(ast%), env%))
DEF FNget_argv
PROCgc_enter

35
impls/c.2/env.c
View File

@ -15,7 +15,7 @@ Env* env_make(Env* outer, list symbol_list, list exprs_list, MalType* more_symbo
while (symbol_list) {
env = env_set(env, symbol_list->data, exprs_list->data);
env_set(env, ((MalType*)symbol_list->data)->value.mal_symbol, exprs_list->data);
symbol_list = symbol_list->next;
exprs_list = exprs_list->next;
@ -23,45 +23,28 @@ Env* env_make(Env* outer, list symbol_list, list exprs_list, MalType* more_symbo
/* set the 'more' symbol if there is one */
if (more_symbol) {
env = env_set(env, more_symbol, make_list(exprs_list));
env_set(env, more_symbol->value.mal_symbol, make_list(exprs_list));
}
return env;
}
Env* env_set(Env* current, MalType* symbol, MalType* value) {
void env_set(Env* current, char* symbol, MalType* value) {
current->data = hashmap_put(current->data, symbol, value);
current->data = hashmap_put(current->data, symbol->value.mal_symbol, value);
return current;
}
Env* env_find(Env* current, MalType* symbol) {
MalType* env_get(Env* current, char* symbol) {
MalType* val = hashmap_get(current->data, symbol->value.mal_symbol);
MalType* val = hashmap_get(current->data, symbol);
if (val) {
return current;
return val;
}
else if (current->outer) {
return env_find(current->outer, symbol);
return env_get(current->outer, symbol);
}
else {
return NULL; /* not found */
}
}
MalType* env_get(Env* current, MalType* symbol) {
Env* env = env_find(current, symbol);
if (env) {
return hashmap_get(env->data, symbol->value.mal_symbol);
}
else {
return make_error_fmt("'%s' not found", symbol->value.mal_symbol);
}
}
Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list)) {
return env_set(current, make_symbol(symbol_name), make_function(fn));
}

6
impls/c.2/env.h
View File

@ -15,9 +15,7 @@ struct Env_s {
};
Env* env_make(Env* outer, list binds, list exprs, MalType* variadic_symbol);
Env* env_set(Env* current, MalType* symbol, MalType* value);
Env* env_set_C_fn(Env* current, char* symbol_name, MalType*(*fn)(list));
MalType* env_get(Env* current, MalType* symbol);
Env* env_find(Env* current, MalType* symbol);
void env_set(Env* current, char* symbol, MalType* value);
MalType* env_get(Env* current, char* symbol);
#endif

90
impls/c.2/step2_eval.c
View File

@ -21,13 +21,41 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
/* printf("EVAL: %s\n", pr_str(ast, READABLY)); */
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = hashmap_get(env->data, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -35,12 +63,10 @@ MalType* EVAL(MalType* ast, Env* env) {
/* list */
/* evaluate the list */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -112,58 +138,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = hashmap_get(env->data, ast->value.mal_symbol);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
list evaluate_list(list lst, Env* env) {
list evlst = NULL;

104
impls/c.2/step3_env.c
View File

@ -24,15 +24,45 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env* env);
MalType* eval_letstar(MalType* ast, Env* env);
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -52,12 +82,10 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -92,10 +120,10 @@ int main(int argc, char** argv) {
puts("Press Ctrl+d to exit\n");
Env* repl_env = env_make(NULL, NULL, NULL, NULL);
repl_env = env_set_C_fn(repl_env, "+", mal_add);
repl_env = env_set_C_fn(repl_env, "-", mal_sub);
repl_env = env_set_C_fn(repl_env, "*", mal_mul);
repl_env = env_set_C_fn(repl_env, "/", mal_div);
env_set(repl_env, "+", make_function(mal_add));
env_set(repl_env, "-", make_function(mal_sub));
env_set(repl_env, "*", make_function(mal_mul));
env_set(repl_env, "/", make_function(mal_div));
while (1) {
@ -122,58 +150,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env* env) {
list lst = (ast->value.mal_list)->next;
@ -185,7 +161,7 @@ MalType* eval_defbang(MalType* ast, Env* env) {
MalType* result = EVAL(defbang_value, env);
if (!is_error(result)) {
env_set(env, defbang_symbol, result);
env_set(env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -206,7 +182,7 @@ MalType* eval_letstar(MalType* ast, Env* env) {
MalType* symbol = letstar_bindings_list->data;
MalType* value = letstar_bindings_list->next->data;
letstar_env = env_set(letstar_env, symbol, EVAL(value, letstar_env));
env_set(letstar_env, symbol->value.mal_symbol, EVAL(value, letstar_env));
letstar_bindings_list = letstar_bindings_list->next->next; /* pop symbol and value*/
}

98
impls/c.2/step4_if_fn_do.c
View File

@ -28,18 +28,48 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env* env);
MalType* eval_letstar(MalType* ast, Env* env);
MalType* eval_if(MalType* ast, Env* env);
MalType* eval_fnstar(MalType* ast, Env* env);
MalType* eval_do(MalType* ast, Env* env);
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -68,12 +98,10 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -131,7 +159,7 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
@ -166,58 +194,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env* env) {
list lst = (ast->value.mal_list)->next;
@ -236,7 +212,7 @@ MalType* eval_defbang(MalType* ast, Env* env) {
MalType* result = EVAL(defbang_value, env);
if (!is_error(result)){
env = env_set(env, defbang_symbol, result);
env_set(env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -272,7 +248,7 @@ MalType* eval_letstar(MalType* ast, Env* env) {
/* early return from error */
if (is_error(value)) { return value; }
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}
return EVAL(forms, letstar_env);

96
impls/c.2/step5_tco.c
View File

@ -28,7 +28,9 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -38,11 +40,39 @@ MalType* EVAL(MalType* ast, Env* env) {
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -86,10 +116,10 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -151,7 +181,7 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
@ -186,58 +216,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -256,7 +234,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -298,7 +276,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}

102
impls/c.2/step6_file.c
View File

@ -28,7 +28,9 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -38,11 +40,39 @@ MalType* EVAL(MalType* ast, Env* env) {
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -86,12 +116,10 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -159,13 +187,13 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
}
env_set_C_fn(repl_env, "eval", mal_eval);
env_set(repl_env, "eval", make_function(mal_eval));
/* add functions written in mal - not using rep as it prints the result */
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
@ -177,7 +205,7 @@ int main(int argc, char** argv) {
for (int i = 2; i < argc; i++) {
lst = list_push(lst, make_string(argv[i]));
}
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
env_set(repl_env, "*ARGV*", make_list(list_reverse(lst)));
/* run in script mode if a filename is given */
if (argc > 1) {
@ -218,58 +246,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -288,7 +264,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -330,7 +306,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}

109
impls/c.2/step7_quote.c
View File

@ -19,7 +19,6 @@
#define SYMBOL_FNSTAR "fn*"
#define SYMBOL_QUOTE "quote"
#define SYMBOL_QUASIQUOTE "quasiquote"
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
#define SYMBOL_UNQUOTE "unquote"
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
@ -33,7 +32,9 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -41,16 +42,43 @@ MalType* EVAL(MalType* ast, Env* env) {
MalType* eval_do(MalType* ast, Env* env);
MalType* eval_quote(MalType* ast);
MalType* eval_quasiquote(MalType* ast);
MalType* eval_quasiquoteexpand(MalType* ast);
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -102,20 +130,13 @@ MalType* EVAL(MalType* ast, Env* env) {
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
list lst = ast->value.mal_list;
return eval_quasiquote(make_list(lst));
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
list evlst = evaluate_list(ast->value.mal_list, env);
if (is_error(evlst->data)) return evlst->data;
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
@ -183,13 +204,13 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
}
env_set_C_fn(repl_env, "eval", mal_eval);
env_set(repl_env, "eval", make_function(mal_eval));
/* add functions written in mal - not using rep as it prints the result */
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
@ -201,7 +222,7 @@ int main(int argc, char** argv) {
for (long i = 2; i < argc; i++) {
lst = list_push(lst, make_string(argv[i]));
}
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
env_set(repl_env, "*ARGV*", make_list(list_reverse(lst)));
/* run in script mode if a filename is given */
if (argc > 1) {
@ -242,58 +263,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -312,7 +281,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -354,7 +323,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}

204
impls/c.2/step8_macros.c
View File

@ -19,11 +19,9 @@
#define SYMBOL_FNSTAR "fn*"
#define SYMBOL_QUOTE "quote"
#define SYMBOL_QUASIQUOTE "quasiquote"
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
#define SYMBOL_UNQUOTE "unquote"
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
#define SYMBOL_DEFMACROBANG "defmacro!"
#define SYMBOL_MACROEXPAND "macroexpand"
#define PROMPT_STRING "user> "
@ -35,7 +33,10 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
MalType* apply(MalType* fn, list args);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -43,23 +44,44 @@ MalType* EVAL(MalType* ast, Env* env) {
MalType* eval_do(MalType* ast, Env* env);
MalType* eval_quote(MalType* ast);
MalType* eval_quasiquote(MalType* ast);
MalType* eval_quasiquoteexpand(MalType* ast);
MalType* eval_defmacrobang(MalType*, Env** env);
MalType* eval_macroexpand(MalType* ast, Env* env);
MalType* macroexpand(MalType* ast, Env* env);
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
/* macroexpansion */
ast = macroexpand(ast, env);
if (is_error(ast)) { return ast; }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -111,30 +133,25 @@ MalType* EVAL(MalType* ast, Env* env) {
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
list lst = ast->value.mal_list;
return eval_quasiquote(make_list(lst));
}
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
return eval_defmacrobang(ast, &env);
}
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
return eval_macroexpand(ast, env);
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
MalType* func = EVAL(first, env);
if (is_error(func)) { return func; }
if (func->is_macro) {
ast = apply(func, ast->value.mal_list->next);
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
list evlst = evaluate_list(ast->value.mal_list->next, env);
if (evlst && is_error(evlst->data)) { return evlst->data; }
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
return (*func->value.mal_function)(evlst->next);
return (*func->value.mal_function)(evlst);
}
else if (is_closure(func)) {
@ -142,7 +159,7 @@ MalType* EVAL(MalType* ast, Env* env) {
list params = (closure->parameters)->value.mal_list;
long param_count = list_count(params);
long arg_count = list_count(evlst->next);
long arg_count = list_count(evlst);
if (param_count > arg_count) {
return make_error("too few arguments supplied to function");
@ -153,7 +170,7 @@ MalType* EVAL(MalType* ast, Env* env) {
else {
/* TCE - modify ast and env directly and jump back to eval */
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
env = env_make(closure->env, params, evlst, closure->more_symbol);
ast = func->value.mal_closure->definition;
if (is_error(ast)) { return ast; }
@ -198,13 +215,13 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
}
env_set_C_fn(repl_env, "eval", mal_eval);
env_set(repl_env, "eval", make_function(mal_eval));
/* add functions written in mal - not using rep as it prints the result */
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
@ -216,7 +233,7 @@ int main(int argc, char** argv) {
for (long i = 2; i < argc; i++) {
lst = list_push(lst, make_string(argv[i]));
}
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
env_set(repl_env, "*ARGV*", make_list(list_reverse(lst)));
/* run in script mode if a filename is given */
if (argc > 1) {
@ -257,58 +274,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -327,7 +292,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -369,7 +334,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}
@ -668,51 +633,11 @@ MalType* eval_defmacrobang(MalType* ast, Env** env) {
if (!is_error(result)) {
result = copy_type(result);
result->is_macro = 1;
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
MalType* eval_macroexpand(MalType* ast, Env* env) {
/* forward reference */
MalType* macroexpand(MalType* ast, Env* env);
list lst = ast->value.mal_list;
if (!lst->next) {
return make_nil();
}
else if (lst->next->next) {
return make_error("'macroexpand': expected exactly one argument");
}
else {
return macroexpand(lst->next->data, env);
}
}
MalType* macroexpand(MalType* ast, Env* env) {
/* forward reference */
int is_macro_call(MalType* ast, Env* env);
while(is_macro_call(ast, env)) {
list lst = ast->value.mal_list;
MalType* macro_fn = env_get(env, lst->data);
MalClosure* cls = macro_fn->value.mal_closure;
MalType* more_symbol = cls->more_symbol;
list params_list = (cls->parameters)->value.mal_list;
list args_list = lst->next;
env = env_make(cls->env, params_list, args_list, more_symbol);
ast = EVAL(cls->definition, env);
}
return ast;
}
list evaluate_list(list lst, Env* env) {
list evlst = NULL;
@ -866,32 +791,3 @@ MalType* apply(MalType* fn, list args) {
}
}
}
int is_macro_call(MalType* ast, Env* env) {
/* not a list */
if (!is_list(ast)) {
return 0;
}
/* empty list */
list lst = ast->value.mal_list;
if (!lst) {
return 0;
}
/* first item not a symbol */
MalType* first = lst->data;
if (!is_symbol(first)) {
return 0;
}
/* lookup symbol */
MalType* val = env_get(env, first);
if (is_error(val)) {
return 0;
}
else {
return (val->is_macro);
}
}

213
impls/c.2/step9_try.c
View File

@ -19,11 +19,9 @@
#define SYMBOL_FNSTAR "fn*"
#define SYMBOL_QUOTE "quote"
#define SYMBOL_QUASIQUOTE "quasiquote"
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
#define SYMBOL_UNQUOTE "unquote"
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
#define SYMBOL_DEFMACROBANG "defmacro!"
#define SYMBOL_MACROEXPAND "macroexpand"
#define SYMBOL_TRYSTAR "try*"
#define SYMBOL_CATCHSTAR "catch*"
@ -37,7 +35,10 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
MalType* apply(MalType* fn, list args);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -45,24 +46,45 @@ MalType* EVAL(MalType* ast, Env* env) {
MalType* eval_do(MalType* ast, Env* env);
MalType* eval_quote(MalType* ast);
MalType* eval_quasiquote(MalType* ast);
MalType* eval_quasiquoteexpand(MalType* ast);
MalType* eval_defmacrobang(MalType*, Env** env);
MalType* eval_macroexpand(MalType* ast, Env* env);
MalType* macroexpand(MalType* ast, Env* env);
void eval_try(MalType** ast, Env** env);
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
/* macroexpansion */
ast = macroexpand(ast, env);
if (is_error(ast)) { return ast; }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -114,17 +136,9 @@ MalType* EVAL(MalType* ast, Env* env) {
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
list lst = ast->value.mal_list;
return eval_quasiquote(make_list(lst));
}
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
return eval_defmacrobang(ast, &env);
}
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
return eval_macroexpand(ast, env);
}
else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) {
/* TCE - modify ast and env directly and jump back to eval */
@ -135,16 +149,19 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
MalType* func = EVAL(first, env);
if (is_error(func)) { return func; }
if (func->is_macro) {
ast = apply(func, ast->value.mal_list->next);
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
list evlst = evaluate_list(ast->value.mal_list->next, env);
if (evlst && is_error(evlst->data)) { return evlst->data; }
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
return (*func->value.mal_function)(evlst->next);
return (*func->value.mal_function)(evlst);
}
else if (is_closure(func)) {
@ -152,7 +169,7 @@ MalType* EVAL(MalType* ast, Env* env) {
list params = (closure->parameters)->value.mal_list;
long param_count = list_count(params);
long arg_count = list_count(evlst->next);
long arg_count = list_count(evlst);
if (param_count > arg_count) {
return make_error("too few arguments supplied to function");
@ -163,7 +180,7 @@ MalType* EVAL(MalType* ast, Env* env) {
else {
/* TCE - modify ast and env directly and jump back to eval */
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
env = env_make(closure->env, params, evlst, closure->more_symbol);
ast = func->value.mal_closure->definition;
if (is_error(ast)) { return ast; }
@ -209,13 +226,13 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = (MalType*(*)(list))mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
}
env_set_C_fn(repl_env, "eval", mal_eval);
env_set(repl_env, "eval", make_function(mal_eval));
/* add functions written in mal - not using rep as it prints the result */
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
@ -227,7 +244,7 @@ int main(int argc, char** argv) {
for (long i = 2; i < argc; i++) {
lst = list_push(lst, make_string(argv[i]));
}
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
env_set(repl_env, "*ARGV*", make_list(list_reverse(lst)));
/* run in script mode if a filename is given */
if (argc > 1) {
@ -268,58 +285,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -338,7 +303,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -380,7 +345,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}
@ -679,51 +644,11 @@ MalType* eval_defmacrobang(MalType* ast, Env** env) {
if (!is_error(result)) {
result = copy_type(result);
result->is_macro = 1;
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
MalType* eval_macroexpand(MalType* ast, Env* env) {
/* forward reference */
MalType* macroexpand(MalType* ast, Env* env);
list lst = ast->value.mal_list;
if (!lst->next) {
return make_nil();
}
else if (lst->next->next) {
return make_error("'macroexpand': expected exactly one argument");
}
else {
return macroexpand(lst->next->data, env);
}
}
MalType* macroexpand(MalType* ast, Env* env) {
/* forward reference */
int is_macro_call(MalType* ast, Env* env);
while(is_macro_call(ast, env)) {
list lst = ast->value.mal_list;
MalType* macro_fn = env_get(env, lst->data);
MalClosure* cls = macro_fn->value.mal_closure;
MalType* more_symbol = cls->more_symbol;
list params_list = (cls->parameters)->value.mal_list;
list args_list = lst->next;
env = env_make(cls->env, params_list, args_list, more_symbol);
ast = EVAL(cls->definition, env);
}
return ast;
}
void eval_try(MalType** ast, Env** env) {
list lst = (*ast)->value.mal_list;
@ -773,11 +698,10 @@ void eval_try(MalType** ast, Env** env) {
}
/* bind the symbol to the exception */
list symbol_list = list_make(catch_list->next->data);
list expr_list = list_make(try_result->value.mal_error);
/* TODO: validate symbols and exprs match before calling env_make */
Env* catch_env = env_make(*env, symbol_list, expr_list, NULL);
Env* catch_env = env_make(*env, NULL, NULL, NULL);
env_set(catch_env,
((MalType*)catch_list->next->data)->value.mal_symbol,
try_result->value.mal_error);
*ast = catch_list->next->next->data;
*env = catch_env;
@ -937,32 +861,3 @@ MalType* apply(MalType* fn, list args) {
}
}
}
int is_macro_call(MalType* ast, Env* env) {
/* not a list */
if (!is_list(ast)) {
return 0;
}
/* empty list */
list lst = ast->value.mal_list;
if (!lst) {
return 0;
}
/* first item not a symbol */
MalType* first = lst->data;
if (!is_symbol(first)) {
return 0;
}
/* lookup symbol */
MalType* val = env_get(env, first);
if (is_error(val)) {
return 0;
}
else {
return (val->is_macro);
}
}

216
impls/c.2/stepA_mal.c
View File

@ -20,11 +20,9 @@
#define SYMBOL_FNSTAR "fn*"
#define SYMBOL_QUOTE "quote"
#define SYMBOL_QUASIQUOTE "quasiquote"
#define SYMBOL_QUASIQUOTEEXPAND "quasiquoteexpand"
#define SYMBOL_UNQUOTE "unquote"
#define SYMBOL_SPLICE_UNQUOTE "splice-unquote"
#define SYMBOL_DEFMACROBANG "defmacro!"
#define SYMBOL_MACROEXPAND "macroexpand"
#define SYMBOL_TRYSTAR "try*"
#define SYMBOL_CATCHSTAR "catch*"
@ -38,7 +36,10 @@ MalType* READ(char* str) {
MalType* EVAL(MalType* ast, Env* env) {
/* forward references */
MalType* eval_ast(MalType* ast, Env* env);
MalType* apply(MalType* fn, list args);
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
MalType* eval_defbang(MalType* ast, Env** env);
void eval_letstar(MalType** ast, Env** env);
void eval_if(MalType** ast, Env** env);
@ -46,24 +47,45 @@ MalType* EVAL(MalType* ast, Env* env) {
MalType* eval_do(MalType* ast, Env* env);
MalType* eval_quote(MalType* ast);
MalType* eval_quasiquote(MalType* ast);
MalType* eval_quasiquoteexpand(MalType* ast);
MalType* eval_defmacrobang(MalType*, Env** env);
MalType* eval_macroexpand(MalType* ast, Env* env);
MalType* macroexpand(MalType* ast, Env* env);
void eval_try(MalType** ast, Env** env);
/* Use goto to jump here rather than calling eval for tail-call elimination */
TCE_entry_point:
MalType* dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && ! is_false(dbgeval) && ! is_nil(dbgeval))
printf("EVAL: %s\n", pr_str(ast, READABLY));
/* NULL */
if (!ast) { return make_nil(); }
/* macroexpansion */
ast = macroexpand(ast, env);
if (is_error(ast)) { return ast; }
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast->value.mal_symbol);
if (symbol_value)
return symbol_value;
else
return make_error_fmt("'%s' not found", ast->value.mal_symbol);
}
if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_vector(result);
}
if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (result && is_error(result->data))
return result->data;
else
return make_hashmap(result);
}
/* not a list */
if (!is_list(ast)) { return eval_ast(ast, env); }
if (!is_list(ast)) { return ast; }
/* empty list */
if (ast->value.mal_list == NULL) { return ast; }
@ -115,17 +137,9 @@ MalType* EVAL(MalType* ast, Env* env) {
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
else if (strcmp(symbol, SYMBOL_QUASIQUOTEEXPAND) == 0) {
list lst = ast->value.mal_list;
return eval_quasiquote(make_list(lst));
}
else if (strcmp(symbol, SYMBOL_DEFMACROBANG) == 0) {
return eval_defmacrobang(ast, &env);
}
else if (strcmp(symbol, SYMBOL_MACROEXPAND) == 0) {
return eval_macroexpand(ast, env);
}
else if (strcmp(symbol, SYMBOL_TRYSTAR) == 0) {
/* TCE - modify ast and env directly and jump back to eval */
@ -136,16 +150,19 @@ MalType* EVAL(MalType* ast, Env* env) {
}
}
/* first element is not a special symbol */
MalType* evaluated_list = eval_ast(ast, env);
if (is_error(evaluated_list)) { return evaluated_list; }
MalType* func = EVAL(first, env);
if (is_error(func)) { return func; }
if (func->is_macro) {
ast = apply(func, ast->value.mal_list->next);
if (is_error(ast)) { return ast; }
goto TCE_entry_point;
}
list evlst = evaluate_list(ast->value.mal_list->next, env);
if (evlst && is_error(evlst->data)) { return evlst->data; }
/* apply the first element of the list to the arguments */
list evlst = evaluated_list->value.mal_list;
MalType* func = evlst->data;
if (is_function(func)) {
return (*func->value.mal_function)(evlst->next);
return (*func->value.mal_function)(evlst);
}
else if (is_closure(func)) {
@ -153,7 +170,7 @@ MalType* EVAL(MalType* ast, Env* env) {
list params = (closure->parameters)->value.mal_list;
long param_count = list_count(params);
long arg_count = list_count(evlst->next);
long arg_count = list_count(evlst);
if (param_count > arg_count) {
return make_error("too few arguments supplied to function");
@ -164,7 +181,7 @@ MalType* EVAL(MalType* ast, Env* env) {
else {
/* TCE - modify ast and env directly and jump back to eval */
env = env_make(closure->env, params, evlst->next, closure->more_symbol);
env = env_make(closure->env, params, evlst, closure->more_symbol);
ast = func->value.mal_closure->definition;
if (is_error(ast)) { return ast; }
@ -233,14 +250,14 @@ int main(int argc, char** argv) {
char* symbol = mappings->data;
MalType*(*function)(list) = mappings->next->data;
env_set_C_fn(repl_env, symbol, function);
env_set(repl_env, symbol, make_function(function));
/* pop symbol and function from hashmap/list */
mappings = mappings->next->next;
}
env_set_C_fn(repl_env, "eval", mal_eval);
env_set_C_fn(repl_env, "readline", mal_readline);
env_set(repl_env, "eval", make_function(mal_eval));
env_set(repl_env, "readline", make_function(mal_readline));
/* add functions written in mal - not using rep as it prints the result */
EVAL(READ("(def! not (fn* (a) (if a false true)))"), repl_env);
@ -252,8 +269,8 @@ int main(int argc, char** argv) {
for (long i = 2; i < argc; i++) {
lst = list_push(lst, make_string(argv[i]));
}
env_set(repl_env, make_symbol("*ARGV*"), make_list(list_reverse(lst)));
env_set(repl_env, make_symbol("*host-language*"), make_string("c.2"));
env_set(repl_env, "*ARGV*", make_list(list_reverse(lst)));
env_set(repl_env, "*host-language*", make_string("c.2"));
/* run in script mode if a filename is given */
if (argc > 1) {
@ -293,58 +310,6 @@ int main(int argc, char** argv) {
return 0;
}
MalType* eval_ast(MalType* ast, Env* env) {
/* forward references */
list evaluate_list(list lst, Env* env);
list evaluate_vector(list lst, Env* env);
list evaluate_hashmap(list lst, Env* env);
if (is_symbol(ast)) {
MalType* symbol_value = env_get(env, ast);
if (symbol_value) {
return symbol_value;
} else {
return make_error_fmt("var '%s' not found", pr_str(ast, UNREADABLY));
}
}
else if (is_list(ast)) {
list result = evaluate_list(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_list(result);
} else {
return result->data;
}
}
else if (is_vector(ast)) {
list result = evaluate_vector(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_vector(result);
} else {
return result->data;
}
}
else if (is_hashmap(ast)) {
list result = evaluate_hashmap(ast->value.mal_list, env);
if (!result || !is_error(result->data)) {
return make_hashmap(result);
} else {
return result->data;
}
}
else {
return ast;
}
}
MalType* eval_defbang(MalType* ast, Env** env) {
list lst = (ast->value.mal_list)->next;
@ -363,7 +328,7 @@ MalType* eval_defbang(MalType* ast, Env** env) {
MalType* result = EVAL(defbang_value, *env);
if (!is_error(result)){
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
@ -405,7 +370,7 @@ void eval_letstar(MalType** ast, Env** env) {
return;
}
env_set(letstar_env, symbol, value);
env_set(letstar_env, symbol->value.mal_symbol, value);
bindings_list = bindings_list->next->next;
}
@ -704,51 +669,11 @@ MalType* eval_defmacrobang(MalType* ast, Env** env) {
if (!is_error(result)) {
result = copy_type(result);
result->is_macro = 1;
*env = env_set(*env, defbang_symbol, result);
env_set(*env, defbang_symbol->value.mal_symbol, result);
}
return result;
}
MalType* eval_macroexpand(MalType* ast, Env* env) {
/* forward reference */
MalType* macroexpand(MalType* ast, Env* env);
list lst = ast->value.mal_list;
if (!lst->next) {
return make_nil();
}
else if (lst->next->next) {
return make_error("'macroexpand': expected exactly one argument");
}
else {
return macroexpand(lst->next->data, env);
}
}
MalType* macroexpand(MalType* ast, Env* env) {
/* forward reference */
int is_macro_call(MalType* ast, Env* env);
while(is_macro_call(ast, env)) {
list lst = ast->value.mal_list;
MalType* macro_fn = env_get(env, lst->data);
MalClosure* cls = macro_fn->value.mal_closure;
MalType* more_symbol = cls->more_symbol;
list params_list = (cls->parameters)->value.mal_list;
list args_list = lst->next;
env = env_make(cls->env, params_list, args_list, more_symbol);
ast = EVAL(cls->definition, env);
}
return ast;
}
void eval_try(MalType** ast, Env** env) {
list lst = (*ast)->value.mal_list;
@ -798,10 +723,10 @@ void eval_try(MalType** ast, Env** env) {
}
/* bind the symbol to the exception */
list symbol_list = list_make(catch_list->next->data);
list expr_list = list_make(try_result->value.mal_error);
Env* catch_env = env_make(*env, symbol_list, expr_list, NULL);
Env* catch_env = env_make(*env, NULL, NULL, NULL);
env_set(catch_env,
((MalType*)catch_list->next->data)->value.mal_symbol,
try_result->value.mal_error);
*ast = catch_list->next->next->data;
*env = catch_env;
@ -961,32 +886,3 @@ MalType* apply(MalType* fn, list args) {
}
}
}
int is_macro_call(MalType* ast, Env* env) {
/* not a list */
if (!is_list(ast)) {
return 0;
}
/* empty list */
list lst = ast->value.mal_list;
if (!lst) {
return 0;
}
/* first item not a symbol */
MalType* first = lst->data;
if (!is_symbol(first)) {
return 0;
}
/* lookup symbol */
MalType* val = env_get(env, first);
if (is_error(val)) {
return 0;
}
else {
return (val->is_macro);
}
}

24
impls/c/env.c
View File

@ -20,10 +20,11 @@ Env *new_env(Env *outer, MalVal* binds, MalVal *exprs) {
if (i > exprs_len) { break; }
if (_nth(binds, i)->val.string[0] == '&') {
varargs = 1;
env_set(e, _nth(binds, i+1), _slice(exprs, i, _count(exprs)));
env_set(e, _nth(binds, i+1)->val.string,
_slice(exprs, i, _count(exprs)));
break;
} else {
env_set(e, _nth(binds, i), _nth(exprs, i));
env_set(e, _nth(binds, i)->val.string, _nth(exprs, i));
}
}
assert(varargs || (binds_len == exprs_len),
@ -34,24 +35,17 @@ Env *new_env(Env *outer, MalVal* binds, MalVal *exprs) {
return e;
}
Env *env_find(Env *env, MalVal *key) {
void *val = g_hash_table_lookup(env->table, key->val.string);
MalVal *env_get(Env *env, const char *key) {
MalVal *val = g_hash_table_lookup(env->table, key);
if (val) {
return env;
return val;
} else if (env->outer) {
return env_find(env->outer, key);
return env_get(env->outer, key);
} else {
return NULL;
}
}
MalVal *env_get(Env *env, MalVal *key) {
Env *e = env_find(env, key);
assert(e, "'%s' not found", key->val.string);
return g_hash_table_lookup(e->table, key->val.string);
}
Env *env_set(Env *env, MalVal *key, MalVal *val) {
g_hash_table_insert(env->table, key->val.string, val);
return env;
void env_set(Env *env, char *key, MalVal *val) {
g_hash_table_insert(env->table, key, val);
}

20
impls/c/step2_eval.c
View File

@ -29,15 +29,19 @@ MalVal *READ(char prompt[], char *str) {
}
// eval
MalVal *eval_ast(MalVal *ast, GHashTable *env) {
MalVal *EVAL(MalVal *ast, GHashTable *env) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
// TODO: check if not found
MalVal *res = g_hash_table_lookup(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -62,22 +66,12 @@ MalVal *eval_ast(MalVal *ast, GHashTable *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, GHashTable *env) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
if (_count(ast) == 0) { return ast; }
MalVal *a0 = _nth(ast, 0);
assert_type(a0, MAL_SYMBOL, "Cannot invoke %s", _pr_str(a0,1));
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el);
//g_print("eval_invoke el: %s\n", _pr_str(el,1));

39
impls/c/step3_env.c
View File

@ -29,12 +29,22 @@ MalVal *READ(char prompt[], char *str) {
}
// eval
MalVal *eval_ast(MalVal *ast, Env *env) {
MalVal *EVAL(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -59,15 +69,6 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
@ -81,7 +82,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if (strcmp("let*", a0->val.string) == 0) {
//g_print("eval apply let*\n");
@ -97,12 +98,12 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
return EVAL(a2, let_env);
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *(*f)(void *, void*) = (MalVal *(*)(void*, void*))_first(el);
return f(_nth(el, 1), _nth(el, 2));
@ -142,10 +143,10 @@ WRAP_INTEGER_OP(divide,/)
void init_repl_env() {
repl_env = new_env(NULL, NULL, NULL);
env_set(repl_env, malval_new_symbol("+"), (MalVal *)int_plus);
env_set(repl_env, malval_new_symbol("-"), (MalVal *)int_minus);
env_set(repl_env, malval_new_symbol("*"), (MalVal *)int_multiply);
env_set(repl_env, malval_new_symbol("/"), (MalVal *)int_divide);
env_set(repl_env, "+", (MalVal *)int_plus);
env_set(repl_env, "-", (MalVal *)int_minus);
env_set(repl_env, "*", (MalVal *)int_multiply);
env_set(repl_env, "/", (MalVal *)int_divide);
}
int main()

36
impls/c/step4_if_fn_do.c
View File

@ -30,12 +30,22 @@ MalVal *READ(char prompt[], char *str) {
}
// eval
MalVal *eval_ast(MalVal *ast, Env *env) {
MalVal *EVAL(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -60,15 +70,6 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
@ -82,7 +83,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -99,13 +100,13 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
return EVAL(a2, let_env);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
MalVal *el = eval_ast(_rest(ast), env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, _rest(ast), env);
return _last(el);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("if", a0->val.string) == 0) {
@ -136,7 +137,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
@ -177,8 +178,7 @@ void init_repl_env() {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}

40
impls/c/step5_tco.c
View File

@ -30,12 +30,24 @@ MalVal *READ(char prompt[], char *str) {
}
// eval
MalVal *eval_ast(MalVal *ast, Env *env) {
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -60,17 +72,6 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
@ -84,7 +85,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -101,7 +102,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -109,7 +110,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast) - 1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -141,7 +142,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
@ -190,8 +191,7 @@ void init_repl_env() {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}

45
impls/c/step6_file.c
View File

@ -30,12 +30,24 @@ MalVal *READ(char prompt[], char *str) {
}
// eval
MalVal *eval_ast(MalVal *ast, Env *env) {
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -60,17 +72,6 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
@ -84,7 +85,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -101,7 +102,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -109,7 +110,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)-1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -141,7 +142,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
@ -192,12 +193,10 @@ void init_repl_env(int argc, char *argv[]) {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}
env_set(repl_env,
malval_new_symbol("eval"),
env_set(repl_env, "eval",
malval_new_function((void*(*)(void *))do_eval, 1));
MalVal *_argv = _listX(0);
@ -205,7 +204,7 @@ void init_repl_env(int argc, char *argv[]) {
MalVal *arg = malval_new_string(argv[i]);
g_array_append_val(_argv->val.array, arg);
}
env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
env_set(repl_env, "*ARGV*", _argv);
// core.mal: defined using the language itself
RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");

48
impls/c/step7_quote.c
View File

@ -68,12 +68,24 @@ MalVal *quasiquote(MalVal *ast) {
}
}
MalVal *eval_ast(MalVal *ast, Env *env) {
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -98,17 +110,6 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
@ -122,7 +123,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -139,7 +140,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -148,9 +149,6 @@ MalVal *EVAL(MalVal *ast, Env *env) {
strcmp("quote", a0->val.string) == 0) {
//g_print("eval apply quote\n");
return _nth(ast, 1);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquoteexpand", a0->val.string) == 0) {
return quasiquote(_nth(ast, 1));
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquote", a0->val.string) == 0) {
//g_print("eval apply quasiquote\n");
@ -160,7 +158,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)-1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -192,7 +190,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
@ -243,12 +241,10 @@ void init_repl_env(int argc, char *argv[]) {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}
env_set(repl_env,
malval_new_symbol("eval"),
env_set(repl_env, "eval",
malval_new_function((void*(*)(void *))do_eval, 1));
MalVal *_argv = _listX(0);
@ -256,7 +252,7 @@ void init_repl_env(int argc, char *argv[]) {
MalVal *arg = malval_new_string(argv[i]);
g_array_append_val(_argv->val.array, arg);
}
env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
env_set(repl_env, "*ARGV*", _argv);
// core.mal: defined using the language itself
RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");

90
impls/c/step8_macros.c
View File

@ -11,7 +11,6 @@
// Declarations
MalVal *EVAL(MalVal *ast, Env *env);
MalVal *quasiquote(MalVal *ast);
MalVal *macroexpand(MalVal *ast, Env *env);
// read
MalVal *READ(char prompt[], char *str) {
@ -69,31 +68,24 @@ MalVal *quasiquote(MalVal *ast) {
}
}
int is_macro_call(MalVal *ast, Env *env) {
if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; }
MalVal *a0 = _nth(ast, 0);
return (a0->type & MAL_SYMBOL) &&
env_find(env, a0) &&
env_get(env, a0)->ismacro;
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
MalVal *macroexpand(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
while (is_macro_call(ast, env)) {
MalVal *a0 = _nth(ast, 0);
MalVal *mac = env_get(env, a0);
// TODO: this is weird and limits it to 20. FIXME
ast = _apply(mac, _rest(ast));
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
return ast;
}
MalVal *eval_ast(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -118,25 +110,8 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
ast = macroexpand(ast, env);
if (!ast || mal_error) return NULL;
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (_count(ast) == 0) { return ast; }
int i, len;
@ -148,7 +123,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -165,7 +140,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -174,9 +149,6 @@ MalVal *EVAL(MalVal *ast, Env *env) {
strcmp("quote", a0->val.string) == 0) {
//g_print("eval apply quote\n");
return _nth(ast, 1);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquoteexpand", a0->val.string) == 0) {
return quasiquote(_nth(ast, 1));
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquote", a0->val.string) == 0) {
//g_print("eval apply quasiquote\n");
@ -188,20 +160,17 @@ MalVal *EVAL(MalVal *ast, Env *env) {
//g_print("eval apply defmacro!\n");
MalVal *a1 = _nth(ast, 1),
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
MalVal *old = EVAL(a2, env);
if (mal_error) return NULL;
MalVal *res = malval_new(MAL_FUNCTION_MAL, NULL);
res->val.func = old->val.func;
res->ismacro = TRUE;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("macroexpand", a0->val.string) == 0) {
//g_print("eval apply macroexpand\n");
MalVal *a1 = _nth(ast, 1);
return macroexpand(a1, env);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)-1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -234,10 +203,15 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
MalVal *f = EVAL(a0, env);
if (!f || mal_error) { return NULL; }
MalVal *rest = _rest(ast);
if (f->ismacro) {
ast = _apply(f, rest);
continue;
}
MalVal *args = _map2((MalVal *(*)(void*, void*))EVAL, rest, env);
if (!args || mal_error) { return NULL; }
assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
"cannot apply '%s'", _pr_str(f,1));
if (f->type & MAL_FUNCTION_MAL) {
@ -285,12 +259,10 @@ void init_repl_env(int argc, char *argv[]) {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}
env_set(repl_env,
malval_new_symbol("eval"),
env_set(repl_env, "eval",
malval_new_function((void*(*)(void *))do_eval, 1));
MalVal *_argv = _listX(0);
@ -298,7 +270,7 @@ void init_repl_env(int argc, char *argv[]) {
MalVal *arg = malval_new_string(argv[i]);
g_array_append_val(_argv->val.array, arg);
}
env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
env_set(repl_env, "*ARGV*", _argv);
// core.mal: defined using the language itself
RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");

90
impls/c/step9_try.c
View File

@ -12,7 +12,6 @@
// Declarations
MalVal *EVAL(MalVal *ast, Env *env);
MalVal *quasiquote(MalVal *ast);
MalVal *macroexpand(MalVal *ast, Env *env);
// read
MalVal *READ(char prompt[], char *str) {
@ -70,31 +69,24 @@ MalVal *quasiquote(MalVal *ast) {
}
}
int is_macro_call(MalVal *ast, Env *env) {
if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; }
MalVal *a0 = _nth(ast, 0);
return (a0->type & MAL_SYMBOL) &&
env_find(env, a0) &&
env_get(env, a0)->ismacro;
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
MalVal *macroexpand(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
while (is_macro_call(ast, env)) {
MalVal *a0 = _nth(ast, 0);
MalVal *mac = env_get(env, a0);
// TODO: this is weird and limits it to 20. FIXME
ast = _apply(mac, _rest(ast));
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
return ast;
}
MalVal *eval_ast(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -119,25 +111,8 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
ast = macroexpand(ast, env);
if (!ast || mal_error) return NULL;
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (_count(ast) == 0) { return ast; }
int i, len;
@ -149,7 +124,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -166,7 +141,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -175,9 +150,6 @@ MalVal *EVAL(MalVal *ast, Env *env) {
strcmp("quote", a0->val.string) == 0) {
//g_print("eval apply quote\n");
return _nth(ast, 1);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquoteexpand", a0->val.string) == 0) {
return quasiquote(_nth(ast, 1));
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquote", a0->val.string) == 0) {
//g_print("eval apply quasiquote\n");
@ -189,16 +161,13 @@ MalVal *EVAL(MalVal *ast, Env *env) {
//g_print("eval apply defmacro!\n");
MalVal *a1 = _nth(ast, 1),
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
MalVal *old = EVAL(a2, env);
if (mal_error) return NULL;
MalVal *res = malval_new(MAL_FUNCTION_MAL, NULL);
res->val.func = old->val.func;
res->ismacro = TRUE;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("macroexpand", a0->val.string) == 0) {
//g_print("eval apply macroexpand\n");
MalVal *a1 = _nth(ast, 1);
return macroexpand(a1, env);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("try*", a0->val.string) == 0) {
//g_print("eval apply try*\n");
@ -226,7 +195,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)-1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -259,10 +228,15 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
MalVal *f = EVAL(a0, env);
if (!f || mal_error) { return NULL; }
MalVal *rest = _rest(ast);
if (f->ismacro) {
ast = _apply(f, rest);
continue;
}
MalVal *args = _map2((MalVal *(*)(void*, void*))EVAL, rest, env);
if (!args || mal_error) { return NULL; }
assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
"cannot apply '%s'", _pr_str(f,1));
if (f->type & MAL_FUNCTION_MAL) {
@ -310,12 +284,10 @@ void init_repl_env(int argc, char *argv[]) {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}
env_set(repl_env,
malval_new_symbol("eval"),
env_set(repl_env, "eval",
malval_new_function((void*(*)(void *))do_eval, 1));
MalVal *_argv = _listX(0);
@ -323,7 +295,7 @@ void init_repl_env(int argc, char *argv[]) {
MalVal *arg = malval_new_string(argv[i]);
g_array_append_val(_argv->val.array, arg);
}
env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
env_set(repl_env, "*ARGV*", _argv);
// core.mal: defined using the language itself
RE(repl_env, "", "(def! not (fn* (a) (if a false true)))");

93
impls/c/stepA_mal.c
View File

@ -12,7 +12,6 @@
// Declarations
MalVal *EVAL(MalVal *ast, Env *env);
MalVal *quasiquote(MalVal *ast);
MalVal *macroexpand(MalVal *ast, Env *env);
// read
MalVal *READ(char prompt[], char *str) {
@ -70,31 +69,24 @@ MalVal *quasiquote(MalVal *ast) {
}
}
int is_macro_call(MalVal *ast, Env *env) {
if (!ast || ast->type != MAL_LIST || _count(ast) == 0) { return 0; }
MalVal *a0 = _nth(ast, 0);
return (a0->type & MAL_SYMBOL) &&
env_find(env, a0) &&
env_get(env, a0)->ismacro;
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
MalVal *macroexpand(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
while (is_macro_call(ast, env)) {
MalVal *a0 = _nth(ast, 0);
MalVal *mac = env_get(env, a0);
// TODO: this is weird and limits it to 20. FIXME
ast = _apply(mac, _rest(ast));
MalVal *dbgeval = env_get(env, "DEBUG-EVAL");
if (dbgeval && !(dbgeval->type & (MAL_FALSE|MAL_NIL))) {
g_print("EVAL: %s\n", _pr_str(ast,1));
}
return ast;
}
MalVal *eval_ast(MalVal *ast, Env *env) {
if (!ast || mal_error) return NULL;
if (ast->type == MAL_SYMBOL) {
//g_print("EVAL symbol: %s\n", ast->val.string);
return env_get(env, ast);
} else if ((ast->type == MAL_LIST) || (ast->type == MAL_VECTOR)) {
MalVal *res = env_get(env, ast->val.string);
assert(res, "'%s' not found", ast->val.string);
return res;
} else if (ast->type == MAL_LIST) {
// Proceed after this conditional.
} else if (ast->type == MAL_VECTOR) {
//g_print("EVAL sequential: %s\n", _pr_str(ast,1));
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, ast, env);
if (!el || mal_error) return NULL;
@ -119,25 +111,8 @@ MalVal *eval_ast(MalVal *ast, Env *env) {
//g_print("EVAL scalar: %s\n", _pr_str(ast,1));
return ast;
}
}
MalVal *EVAL(MalVal *ast, Env *env) {
while (TRUE) {
if (!ast || mal_error) return NULL;
//g_print("EVAL: %s\n", _pr_str(ast,1));
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (!ast || mal_error) return NULL;
// apply list
//g_print("EVAL apply list: %s\n", _pr_str(ast,1));
ast = macroexpand(ast, env);
if (!ast || mal_error) return NULL;
if (ast->type != MAL_LIST) {
return eval_ast(ast, env);
}
if (_count(ast) == 0) { return ast; }
int i, len;
@ -149,7 +124,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
if (mal_error) return NULL;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("let*", a0->val.string) == 0) {
@ -166,7 +141,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
key = g_array_index(a1->val.array, MalVal*, i);
val = g_array_index(a1->val.array, MalVal*, i+1);
assert_type(key, MAL_SYMBOL, "let* bind to non-symbol");
env_set(let_env, key, EVAL(val, let_env));
env_set(let_env, key->val.string, EVAL(val, let_env));
}
ast = a2;
env = let_env;
@ -175,9 +150,6 @@ MalVal *EVAL(MalVal *ast, Env *env) {
strcmp("quote", a0->val.string) == 0) {
//g_print("eval apply quote\n");
return _nth(ast, 1);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquoteexpand", a0->val.string) == 0) {
return quasiquote(_nth(ast, 1));
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("quasiquote", a0->val.string) == 0) {
//g_print("eval apply quasiquote\n");
@ -189,20 +161,18 @@ MalVal *EVAL(MalVal *ast, Env *env) {
//g_print("eval apply defmacro!\n");
MalVal *a1 = _nth(ast, 1),
*a2 = _nth(ast, 2);
MalVal *res = EVAL(a2, env);
MalVal *old = EVAL(a2, env);
if (mal_error) return NULL;
MalVal *res = malval_new(MAL_FUNCTION_MAL, NULL);
res->val.func = old->val.func;
res->ismacro = TRUE;
env_set(env, a1, res);
env_set(env, a1->val.string, res);
return res;
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("macroexpand", a0->val.string) == 0) {
//g_print("eval apply macroexpand\n");
MalVal *a1 = _nth(ast, 1);
return macroexpand(a1, env);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp(".", a0->val.string) == 0) {
//g_print("eval apply .\n");
MalVal *el = eval_ast(_slice(ast, 1, _count(ast)), env);
MalVal *el = _map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)), env);
if (!el || mal_error) return NULL;
return invoke_native(el);
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("try*", a0->val.string) == 0) {
@ -231,7 +201,7 @@ MalVal *EVAL(MalVal *ast, Env *env) {
} else if ((a0->type & MAL_SYMBOL) &&
strcmp("do", a0->val.string) == 0) {
//g_print("eval apply do\n");
eval_ast(_slice(ast, 1, _count(ast)-1), env);
_map2((MalVal *(*)(void*, void*))EVAL, _slice(ast, 1, _count(ast)-1), env);
ast = _last(ast);
// Continue loop
} else if ((a0->type & MAL_SYMBOL) &&
@ -264,10 +234,15 @@ MalVal *EVAL(MalVal *ast, Env *env) {
return mf;
} else {
//g_print("eval apply\n");
MalVal *el = eval_ast(ast, env);
if (!el || mal_error) { return NULL; }
MalVal *f = _first(el),
*args = _rest(el);
MalVal *f = EVAL(a0, env);
if (!f || mal_error) { return NULL; }
MalVal *rest = _rest(ast);
if (f->ismacro) {
ast = _apply(f, rest);
continue;
}
MalVal *args = _map2((MalVal *(*)(void*, void*))EVAL, rest, env);
if (!args || mal_error) { return NULL; }
assert_type(f, MAL_FUNCTION_C|MAL_FUNCTION_MAL,
"cannot apply '%s'", _pr_str(f,1));
if (f->type & MAL_FUNCTION_MAL) {
@ -315,12 +290,10 @@ void init_repl_env(int argc, char *argv[]) {
// core.c: defined using C
int i;
for(i=0; i < (sizeof(core_ns) / sizeof(core_ns[0])); i++) {
env_set(repl_env,
malval_new_symbol(core_ns[i].name),
env_set(repl_env, core_ns[i].name,
malval_new_function(core_ns[i].func, core_ns[i].arg_cnt));
}
env_set(repl_env,
malval_new_symbol("eval"),
env_set(repl_env, "eval",
malval_new_function((void*(*)(void *))do_eval, 1));
MalVal *_argv = _listX(0);
@ -328,7 +301,7 @@ void init_repl_env(int argc, char *argv[]) {
MalVal *arg = malval_new_string(argv[i]);
g_array_append_val(_argv->val.array, arg);
}
env_set(repl_env, malval_new_symbol("*ARGV*"), _argv);
env_set(repl_env, "*ARGV*", _argv);
// core.mal: defined using the language itself
RE(repl_env, "", "(def! *host-language* \"c\")");

6
impls/c/types.h
View File

@ -35,9 +35,9 @@ typedef struct Env {
} Env;
Env *new_env(Env *outer, struct MalVal* binds, struct MalVal *exprs);
Env *env_find(Env *env, struct MalVal *key);
struct MalVal *env_get(Env *env, struct MalVal *key);
Env *env_set(Env *env, struct MalVal *key, struct MalVal *val);
struct MalVal *env_get(Env *env, const char *key);
// Returns NULL if the key is missing.
void env_set(Env *env, char *key, struct MalVal *val);
// Utility functiosn

30
impls/clojure/src/mal/step2_eval.cljc
View File

@ -10,36 +10,32 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(defn eval-ast [ast env]
(defn EVAL [ast env]
;; (println "EVAL:" (printer/pr-str ast) (keys @env))
;; (flush)
(cond
(symbol? ast) (or (get env ast)
(throw (#?(:clj Error.
:cljs js/Error.) (str ast " not found"))))
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
;; indented to match later steps
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(if (empty? ast)
ast
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)]
(apply f args)))))
(apply f args)))
:else ;; not a list, map, symbol or vector
ast))
;; print
(defn PRINT [exp] (printer/pr-str exp))

35
impls/clojure/src/mal/step3_env.cljc
View File

@ -11,26 +11,24 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(defn eval-ast [ast env]
(defn EVAL [ast env]
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
;; indented to match later steps
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
@ -48,10 +46,13 @@
(EVAL a2 let-env))
;; apply
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)]
(apply f args))))))
(apply f args))))
:else ;; not a list, map, symbol or vector
ast))
;; print
(defn PRINT [exp] (printer/pr-str exp))

37
impls/clojure/src/mal/step4_if_fn_do.cljc
View File

@ -12,26 +12,24 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(defn eval-ast [ast env]
(defn EVAL [ast env]
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
;; indented to match later steps
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
@ -49,7 +47,7 @@
(EVAL a2 let-env))
'do
(last (eval-ast (rest ast) env))
(last (doall (map #(EVAL % env) (rest ast))))
'if
(let [cond (EVAL a1 env)]
@ -64,10 +62,13 @@
(EVAL a2 (env/env env a1 (or args '()))))
;; apply
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)]
(apply f args))))))
(apply f args))))
:else ;; not a list, map, symbol or vector
ast))
;; print
(defn PRINT [exp] (printer/pr-str exp))

43
impls/clojure/src/mal/step5_tco.cljc
View File

@ -12,27 +12,26 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
@ -50,7 +49,7 @@
(recur a2 let-env))
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -70,13 +69,17 @@
:parameters a1})
;; apply
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))
(apply f args)))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

43
impls/clojure/src/mal/step6_file.cljc
View File

@ -12,27 +12,26 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
@ -50,7 +49,7 @@
(recur a2 let-env))
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -70,13 +69,17 @@
:parameters a1})
;; apply
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))
(apply f args)))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

53
impls/clojure/src/mal/step7_quote.cljc
View File

@ -12,8 +12,6 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(declare quasiquote)
(defn starts_with [ast sym]
(and (seq? ast)
@ -27,32 +25,32 @@
(list 'concat (second elt) acc)
(list 'cons (quasiquote elt) acc)))))
(defn quasiquote [ast]
(cond (starts_with ast 'unquote) (second ast)
(seq? ast) (qq-iter ast)
(vector? ast) (list 'vec (qq-iter ast))
(cond (starts_with ast 'unquote) (second ast)
(seq? ast) (qq-iter ast)
(vector? ast) (list 'vec (qq-iter ast))
(or (symbol? ast) (map? ast)) (list 'quote ast)
:else ast))
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
@ -72,14 +70,11 @@
'quote
a1
'quasiquoteexpand
(quasiquote a1)
'quasiquote
(recur (quasiquote a1) env)
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -99,13 +94,17 @@
:parameters a1})
;; apply
(let [el (eval-ast ast env)
(let [el (map #(EVAL % env) ast)
f (first el)
args (rest el)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))
(apply f args)))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

77
impls/clojure/src/mal/step8_macros.cljc
View File

@ -1,5 +1,4 @@
(ns mal.step8-macros
(:refer-clojure :exclude [macroexpand])
(:require [mal.readline :as readline]
#?(:clj [clojure.repl])
[mal.reader :as reader]
@ -13,8 +12,6 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(declare quasiquote)
(defn starts_with [ast sym]
(and (seq? ast)
@ -34,46 +31,28 @@
(or (symbol? ast) (map? ast)) (list 'quote ast)
:else ast))
(defn is-macro-call [ast env]
(and (seq? ast)
(symbol? (first ast))
(env/env-find env (first ast))
(:ismacro (meta (env/env-get env (first ast))))))
(defn macroexpand [ast env]
(loop [ast ast]
(if (is-macro-call ast env)
;; Get original unadorned function because ClojureScript (1.10)
;; limits functions with meta on them to arity 20
(let [mac (:orig (meta (env/env-get env (first ast))))]
(recur (apply mac (rest ast))))
ast)))
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
(let [ast (macroexpand ast env)]
(if (not (seq? ast))
(eval-ast ast env)
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
(condp = a0
nil
@ -91,9 +70,6 @@
'quote
a1
'quasiquoteexpand
(quasiquote a1)
'quasiquote
(recur (quasiquote a1) env)
@ -105,11 +81,8 @@
:ismacro true})]
(env/env-set env a1 mac))
'macroexpand
(macroexpand a1 env)
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -133,13 +106,19 @@
:parameters a1}))
;; apply
(let [el (eval-ast ast env)
f (first el)
args (rest el)
(let [f (EVAL a0 env)
unevaluated_args (rest ast)]
(if (:ismacro (meta f))
(recur (apply (:orig (meta f)) unevaluated_args) env)
(let [args (map #(EVAL % env) unevaluated_args)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))))
(apply f args)))))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

77
impls/clojure/src/mal/step9_try.cljc
View File

@ -1,5 +1,4 @@
(ns mal.step9-try
(:refer-clojure :exclude [macroexpand])
(:require [mal.readline :as readline]
#?(:clj [clojure.repl])
[mal.reader :as reader]
@ -13,8 +12,6 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(declare quasiquote)
(defn starts_with [ast sym]
(and (seq? ast)
@ -34,46 +31,28 @@
(or (symbol? ast) (map? ast)) (list 'quote ast)
:else ast))
(defn is-macro-call [ast env]
(and (seq? ast)
(symbol? (first ast))
(env/env-find env (first ast))
(:ismacro (meta (env/env-get env (first ast))))))
(defn macroexpand [ast env]
(loop [ast ast]
(if (is-macro-call ast env)
;; Get original unadorned function because ClojureScript (1.10)
;; limits functions with meta on them to arity 20
(let [mac (:orig (meta (env/env-get env (first ast))))]
(recur (apply mac (rest ast))))
ast)))
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
(let [ast (macroexpand ast env)]
(if (not (seq? ast))
(eval-ast ast env)
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
(condp = a0
nil
@ -91,9 +70,6 @@
'quote
a1
'quasiquoteexpand
(quasiquote a1)
'quasiquote
(recur (quasiquote a1) env)
@ -105,9 +81,6 @@
:ismacro true})]
(env/env-set env a1 mac))
'macroexpand
(macroexpand a1 env)
'try*
(if (= 'catch* (nth a2 0))
(try
@ -126,7 +99,7 @@
(EVAL a1 env))
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -150,13 +123,19 @@
:parameters a1}))
;; apply
(let [el (eval-ast ast env)
f (first el)
args (rest el)
(let [f (EVAL a0 env)
unevaluated_args (rest ast)]
(if (:ismacro (meta f))
(recur (apply (:orig (meta f)) unevaluated_args) env)
(let [args (map #(EVAL % env) unevaluated_args)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))))
(apply f args)))))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

77
impls/clojure/src/mal/stepA_mal.cljc
View File

@ -1,5 +1,4 @@
(ns mal.stepA-mal
(:refer-clojure :exclude [macroexpand])
(:require [mal.readline :as readline]
#?(:clj [clojure.repl])
[mal.reader :as reader]
@ -13,8 +12,6 @@
(reader/read-string strng))
;; eval
(declare EVAL)
(declare quasiquote)
(defn starts_with [ast sym]
(and (seq? ast)
@ -34,46 +31,28 @@
(or (symbol? ast) (map? ast)) (list 'quote ast)
:else ast))
(defn is-macro-call [ast env]
(and (seq? ast)
(symbol? (first ast))
(env/env-find env (first ast))
(:ismacro (meta (env/env-get env (first ast))))))
(defn macroexpand [ast env]
(loop [ast ast]
(if (is-macro-call ast env)
;; Get original unadorned function because ClojureScript (1.10)
;; limits functions with meta on them to arity 20
(let [mac (:orig (meta (env/env-get env (first ast))))]
(recur (apply mac (rest ast))))
ast)))
(defn eval-ast [ast env]
(cond
(symbol? ast) (env/env-get env ast)
(seq? ast) (doall (map #(EVAL % env) ast))
(vector? ast) (vec (doall (map #(EVAL % env) ast)))
(map? ast) (apply hash-map (doall (map #(EVAL % env)
(mapcat identity ast))))
:else ast))
(defn EVAL [ast env]
(loop [ast ast
env env]
;;(prn "EVAL" ast (keys @env)) (flush)
(if (not (seq? ast))
(eval-ast ast env)
(let [e (env/env-find env 'DEBUG-EVAL)]
(when e
(let [v (env/env-get e 'DEBUG-EVAL)]
(when (and (not= v nil)
(not= v false))
(println "EVAL:" (printer/pr-str ast) (keys @env))
(flush)))))
(cond
(symbol? ast) (env/env-get env ast)
(vector? ast) (vec (map #(EVAL % env) ast))
(map? ast) (apply hash-map (map #(EVAL % env) (mapcat identity ast)))
(seq? ast)
;; apply list
(let [ast (macroexpand ast env)]
(if (not (seq? ast))
(eval-ast ast env)
;; indented to match later steps
(let [[a0 a1 a2 a3] ast]
(condp = a0
nil
@ -91,9 +70,6 @@
'quote
a1
'quasiquoteexpand
(quasiquote a1)
'quasiquote
(recur (quasiquote a1) env)
@ -105,9 +81,6 @@
:ismacro true})]
(env/env-set env a1 mac))
'macroexpand
(macroexpand a1 env)
'clj*
#?(:clj (eval (reader/read-string a1))
:cljs (throw (ex-info "clj* unsupported in ClojureScript mode" {})))
@ -134,7 +107,7 @@
(EVAL a1 env))
'do
(do (eval-ast (->> ast (drop-last) (drop 1)) env)
(do (doall (map #(EVAL % env) (->> ast (drop-last) (drop 1))))
(recur (last ast) env))
'if
@ -158,13 +131,19 @@
:parameters a1}))
;; apply
(let [el (eval-ast ast env)
f (first el)
args (rest el)
(let [f (EVAL a0 env)
unevaluated_args (rest ast)]
(if (:ismacro (meta f))
(recur (apply (:orig (meta f)) unevaluated_args) env)
(let [args (map #(EVAL % env) unevaluated_args)
{:keys [expression environment parameters]} (meta f)]
(if expression
(recur expression (env/env environment parameters args))
(apply f args))))))))))
(apply f args)))))))
:else ;; not a list, map, symbol or vector
ast)))
;; print
(defn PRINT [exp] (printer/pr-str exp))

10
impls/coffee/env.coffee
View File

@ -12,9 +12,7 @@ exports.Env = class Env
else
@data[b.name] = @exprs[i]
find: (key) ->
if not types._symbol_Q(key)
throw new Error("env.find key must be symbol")
if key.name of @data then @
if key of @data then @
else if @outer then @outer.find(key)
else null
set: (key, value) ->
@ -22,10 +20,8 @@ exports.Env = class Env
throw new Error("env.set key must be symbol")
@data[key.name] = value
get: (key) ->
if not types._symbol_Q(key)
throw new Error("env.get key must be symbol")
env = @find(key)
throw new Error("'" + key.name + "' not found") if !env
env.data[key.name]
throw new Error("'" + key + "' not found") if !env
env.data[key]
# vim: ts=2:sw=2

20
impls/coffee/step2_eval.coffee
View File

@ -7,24 +7,24 @@ printer = require "./printer.coffee"
READ = (str) -> reader.read_str str
# eval
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env[ast.name]
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
# console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env[ast.name]
else if types._list_Q(ast) then # exit this switch
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
f(args...)

23
impls/coffee/step3_env.coffee
View File

@ -8,20 +8,23 @@ Env = require("./env.coffee").Env
READ = (str) -> reader.read_str str
# eval
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
@ -35,7 +38,7 @@ EVAL = (ast, env) ->
let_env.set(a1[i], EVAL(a1[i+1], let_env))
EVAL(a2, let_env)
else
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
f(args...)

25
impls/coffee/step4_if_fn_do.coffee
View File

@ -9,20 +9,23 @@ core = require("./core.coffee")
READ = (str) -> reader.read_str str
# eval
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
@ -36,7 +39,7 @@ EVAL = (ast, env) ->
let_env.set(a1[i], EVAL(a1[i+1], let_env))
EVAL(a2, let_env)
when "do"
el = eval_ast(ast[1..], env)
el = ast[1..].map((a) -> EVAL(a, env))
el[el.length-1]
when "if"
cond = EVAL(a1, env)
@ -47,7 +50,7 @@ EVAL = (ast, env) ->
when "fn*"
(args...) -> EVAL(a2, new Env(env, a1, args))
else
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
f(args...)

27
impls/coffee/step5_tco.coffee
View File

@ -9,21 +9,24 @@ core = require("./core.coffee")
READ = (str) -> reader.read_str str
# eval
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
@ -38,7 +41,7 @@ EVAL = (ast, env) ->
ast = a2
env = let_env
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -49,7 +52,7 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

27
impls/coffee/step6_file.coffee
View File

@ -9,21 +9,24 @@ core = require("./core.coffee")
READ = (str) -> reader.read_str str
# eval
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
@ -38,7 +41,7 @@ EVAL = (ast, env) ->
ast = a2
env = let_env
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -49,7 +52,7 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

29
impls/coffee/step7_quote.coffee
View File

@ -25,21 +25,24 @@ quasiquote = (ast) ->
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
return new_hm
else return ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
# apply list
@ -55,12 +58,10 @@ EVAL = (ast, env) ->
env = let_env
when "quote"
return a1
when "quasiquoteexpand"
return quasiquote(a1)
when "quasiquote"
ast = quasiquote(a1)
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -71,7 +72,7 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
[f, args...] = ast.map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

47
impls/coffee/step8_macros.coffee
View File

@ -23,36 +23,25 @@ quasiquote = (ast) ->
else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast]
else ast
is_macro_call = (ast, env) ->
return types._list_Q(ast) && types._symbol_Q(ast[0]) &&
env.find(ast[0]) && env.get(ast[0]).__ismacro__
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
macroexpand = (ast, env) ->
while is_macro_call(ast, env)
ast = env.get(ast[0])(ast[1..]...)
ast
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
return new_hm
else return ast
# apply list
ast = macroexpand ast, env
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
[a0, a1, a2, a3] = ast
@ -67,8 +56,6 @@ EVAL = (ast, env) ->
env = let_env
when "quote"
return a1
when "quasiquoteexpand"
return quasiquote(a1)
when "quasiquote"
ast = quasiquote(a1)
when "defmacro!"
@ -76,10 +63,8 @@ EVAL = (ast, env) ->
f = types._clone(f)
f.__ismacro__ = true
return env.set(a1, f)
when "macroexpand"
return macroexpand(a1, env)
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -90,7 +75,11 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
f = EVAL(a0, env)
if f.__ismacro__
ast = EVAL(f.__ast__, f.__gen_env__(ast[1..]))
continue
args = ast[1..].map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

47
impls/coffee/step9_try.coffee
View File

@ -23,36 +23,25 @@ quasiquote = (ast) ->
else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast]
else ast
is_macro_call = (ast, env) ->
return types._list_Q(ast) && types._symbol_Q(ast[0]) &&
env.find(ast[0]) && env.get(ast[0]).__ismacro__
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
macroexpand = (ast, env) ->
while is_macro_call(ast, env)
ast = env.get(ast[0])(ast[1..]...)
ast
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
return new_hm
else return ast
# apply list
ast = macroexpand ast, env
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
[a0, a1, a2, a3] = ast
@ -67,8 +56,6 @@ EVAL = (ast, env) ->
env = let_env
when "quote"
return a1
when "quasiquoteexpand"
return quasiquote(a1)
when "quasiquote"
ast = quasiquote(a1)
when "defmacro!"
@ -76,8 +63,6 @@ EVAL = (ast, env) ->
f = types._clone(f)
f.__ismacro__ = true
return env.set(a1, f)
when "macroexpand"
return macroexpand(a1, env)
when "try*"
try return EVAL(a1, env)
catch exc
@ -88,7 +73,7 @@ EVAL = (ast, env) ->
else
throw exc
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -99,7 +84,11 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
f = EVAL(a0, env)
if f.__ismacro__
ast = EVAL(f.__ast__, f.__gen_env__(ast[1..]))
continue
args = ast[1..].map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

49
impls/coffee/stepA_mal.coffee
View File

@ -23,36 +23,25 @@ quasiquote = (ast) ->
else if types._symbol_Q(ast) || types._hash_map_Q(ast) then [types._symbol('quote'), ast]
else ast
is_macro_call = (ast, env) ->
return types._list_Q(ast) && types._symbol_Q(ast[0]) &&
env.find(ast[0]) && env.get(ast[0]).__ismacro__
EVAL = (ast, env) ->
loop
dbgenv = env.find("DEBUG-EVAL")
if dbgenv
dbgeval = dbgenv.get("DEBUG-EVAL")
if dbgeval != null and dbgeval != false
console.log "EVAL:", printer._pr_str ast
macroexpand = (ast, env) ->
while is_macro_call(ast, env)
ast = env.get(ast[0])(ast[1..]...)
ast
eval_ast = (ast, env) ->
if types._symbol_Q(ast) then env.get ast
else if types._list_Q(ast) then ast.map((a) -> EVAL(a, env))
if types._symbol_Q(ast) then return env.get ast.name
else if types._list_Q(ast) then # exit this switch
else if types._vector_Q(ast)
types._vector(ast.map((a) -> EVAL(a, env))...)
return types._vector(ast.map((a) -> EVAL(a, env))...)
else if types._hash_map_Q(ast)
new_hm = {}
new_hm[k] = EVAL(v, env) for k,v of ast
new_hm
else ast
EVAL = (ast, env) ->
loop
#console.log "EVAL:", printer._pr_str ast
if !types._list_Q ast then return eval_ast ast, env
return new_hm
else return ast
# apply list
ast = macroexpand ast, env
if !types._list_Q ast then return eval_ast ast, env
if ast.length == 0 then return ast
[a0, a1, a2, a3] = ast
@ -67,8 +56,6 @@ EVAL = (ast, env) ->
env = let_env
when "quote"
return a1
when "quasiquoteexpand"
return quasiquote(a1)
when "quasiquote"
ast = quasiquote(a1)
when "defmacro!"
@ -76,8 +63,6 @@ EVAL = (ast, env) ->
f = types._clone(f)
f.__ismacro__ = true
return env.set(a1, f)
when "macroexpand"
return macroexpand(a1, env)
when "try*"
try return EVAL(a1, env)
catch exc
@ -91,10 +76,10 @@ EVAL = (ast, env) ->
res = eval(a1.toString())
return if typeof(res) == 'undefined' then null else res
when "."
el = eval_ast(ast[2..], env)
el = ast[2..].map((a) -> EVAL(a, env))
return eval(a1.toString())(el...)
when "do"
eval_ast(ast[1..-2], env)
ast[1..-2].map((a) -> EVAL(a, env))
ast = ast[ast.length-1]
when "if"
cond = EVAL(a1, env)
@ -105,7 +90,11 @@ EVAL = (ast, env) ->
when "fn*"
return types._function(EVAL, a2, env, a1)
else
[f, args...] = eval_ast ast, env
f = EVAL(a0, env)
if f.__ismacro__
ast = EVAL(f.__ast__, f.__gen_env__(ast[1..]))
continue
args = ast[1..].map((a) -> EVAL(a, env))
if types._function_Q(f)
ast = f.__ast__
env = f.__gen_env__(args)

15
impls/common-lisp/src/env.lisp
View File

@ -4,7 +4,6 @@
(:export :undefined-symbol
:create-mal-env
:get-env
:find-env
:set-env
:mal-env-bindings))
@ -30,16 +29,12 @@
(bindings (make-hash-table :test 'equal) :read-only t)
(parent nil :read-only t))
(defun find-env (env symbol)
(when env
(or (gethash (mal-data-value symbol)
(mal-env-bindings env))
(find-env (mal-env-parent env) symbol))))
(defun get-env (env symbol)
(or (find-env env symbol)
(error 'undefined-symbol
:symbol (format nil "~a" (mal-data-value symbol)))))
(or (gethash symbol (mal-env-bindings env))
(let ((outer (mal-env-parent env)))
(if outer
(get-env outer symbol)
nil))))
(defun set-env (env symbol value)
(setf (gethash (mal-data-value symbol) (mal-env-bindings env)) value))

41
impls/common-lisp/src/step2_eval.lisp
View File

@ -17,37 +17,38 @@
(in-package :mal)
(defvar *repl-env* (make-mal-value-hash-table))
(defvar *repl-env* (make-hash-table :test 'equal))
(setf (genhash:hashref (make-mal-symbol "+") *repl-env*)
(setf (gethash "+" *repl-env*)
(make-mal-builtin-fn (lambda (value1 value2)
(make-mal-number (+ (mal-data-value value1)
(mal-data-value value2))))))
(setf (genhash:hashref (make-mal-symbol "-") *repl-env*)
(setf (gethash "-" *repl-env*)
(make-mal-builtin-fn (lambda (value1 value2)
(make-mal-number (- (mal-data-value value1)
(mal-data-value value2))))))
(setf (genhash:hashref (make-mal-symbol "*") *repl-env*)
(setf (gethash "*" *repl-env*)
(make-mal-builtin-fn (lambda (value1 value2)
(make-mal-number (* (mal-data-value value1)
(mal-data-value value2))))))
(setf (genhash:hashref (make-mal-symbol "/") *repl-env*)
(setf (gethash "/" *repl-env*)
(make-mal-builtin-fn (lambda (value1 value2)
(make-mal-number (/ (mal-data-value value1)
(mal-data-value value2))))))
(defun lookup-env (symbol env)
(let ((value (genhash:hashref symbol env)))
(if value
(let ((key (mal-data-value symbol)))
(multiple-value-bind (value present-p) (gethash key env)
(if present-p
value
(error 'env:undefined-symbol
:symbol (format nil "~a" (mal-data-value symbol))))))
:symbol (format nil "~a" key))))))
(defun eval-sequence (sequence env)
(map 'list
(defun eval-sequence (type sequence env)
(map type
(lambda (ast) (mal-eval ast env))
(mal-data-value sequence)))
@ -60,25 +61,25 @@
hash-map-value)
(make-mal-hash-map new-hash-table)))
(defun eval-ast (ast env)
(defun mal-eval (ast env)
;; (write-line (format nil "EVAL: ~a" (pr-str ast)))
;; (force-output *standard-output*)
(switch-mal-type ast
(types:symbol (lookup-env ast env))
(types:list (eval-sequence ast env))
(types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
(types:list (eval-list ast env))
(types:vector (make-mal-vector (eval-sequence 'vector ast env)))
(types:hash-map (eval-hash-map ast env ))
(types:any ast)))
(defun mal-read (string)
(reader:read-str string))
(defun mal-eval (ast env)
(cond
((not (mal-list-p ast)) (eval-ast ast env))
((zerop (length (mal-data-value ast))) ast)
(t (progn
(let ((evaluated-list (eval-ast ast env)))
(defun eval-list (ast env)
(if (null (mal-data-value ast))
ast
(let ((evaluated-list (eval-sequence 'list ast env)))
(apply (mal-data-value (car evaluated-list))
(cdr evaluated-list)))))))
(cdr evaluated-list)))))
(defun mal-print (expression)
(printer:pr-str expression))

31
impls/common-lisp/src/step3_env.lisp
View File

@ -47,8 +47,8 @@
(defvar mal-def! (make-mal-symbol "def!"))
(defvar mal-let* (make-mal-symbol "let*"))
(defun eval-sequence (sequence env)
(map 'list
(defun eval-sequence (type sequence env)
(map type
(lambda (ast) (mal-eval ast env))
(mal-data-value sequence)))
@ -61,11 +61,20 @@
hash-map-value)
(make-mal-hash-map new-hash-table)))
(defun eval-ast (ast env)
(defun mal-eval (ast env)
(let ((debug-eval (env:get-env env "DEBUG-EVAL")))
(when (and debug-eval
(not (mal-data-value= debug-eval mal-false))
(not (mal-data-value= debug-eval mal-false)))
(write-line (format nil "EVAL: ~a" (pr-str ast)))
(force-output *standard-output*)))
(switch-mal-type ast
(types:symbol (env:get-env env ast))
(types:list (eval-sequence ast env))
(types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
(types:symbol
(let ((key (mal-data-value ast)))
(or (env:get-env env key)
(error 'undefined-symbol :symbol (format nil "~a" key)))))
(types:list (eval-list ast env))
(types:vector (make-mal-vector (eval-sequence 'vector ast env)))
(types:hash-map (eval-hash-map ast env ))
(types:any ast)))
@ -89,24 +98,18 @@
(defun eval-list (ast env)
(let ((forms (mal-data-value ast)))
(cond
((zerop (length forms)) ast)
((mal-data-value= mal-def! (first forms))
(env:set-env env (second forms) (mal-eval (third forms) env)))
((mal-data-value= mal-let* (first forms))
(eval-let* forms env))
(t (let ((evaluated-list (eval-ast ast env)))
(t (let ((evaluated-list (eval-sequence 'list ast env)))
(apply (mal-data-value (car evaluated-list))
(cdr evaluated-list)))))))
(defun mal-read (string)
(reader:read-str string))
(defun mal-eval (ast env)
(cond
((null ast) mal-nil)
((not (mal-list-p ast)) (eval-ast ast env))
((zerop (length (mal-data-value ast))) ast)
(t (eval-list ast env))))
(defun mal-print (expression)
(printer:pr-str expression))

33
impls/common-lisp/src/step4_if_fn_do.lisp
View File

@ -30,8 +30,8 @@
(defvar mal-if (make-mal-symbol "if"))
(defvar mal-fn* (make-mal-symbol "fn*"))
(defun eval-sequence (sequence env)
(map 'list
(defun eval-sequence (type sequence env)
(map type
(lambda (ast) (mal-eval ast env))
(mal-data-value sequence)))
@ -44,11 +44,20 @@
hash-map-value)
(make-mal-hash-map new-hash-table)))
(defun eval-ast (ast env)
(defun mal-eval (ast env)
(let ((debug-eval (env:get-env env "DEBUG-EVAL")))
(when (and debug-eval
(not (mal-data-value= debug-eval mal-false))
(not (mal-data-value= debug-eval mal-false)))
(write-line (format nil "EVAL: ~a" (pr-str ast)))
(force-output *standard-output*)))
(switch-mal-type ast
(types:symbol (env:get-env env ast))
(types:list (eval-sequence ast env))
(types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
(types:symbol
(let ((key (mal-data-value ast)))
(or (env:get-env env key)
(error 'undefined-symbol :symbol (format nil "~a" key)))))
(types:list (eval-list ast env))
(types:vector (make-mal-vector (eval-sequence 'vector ast env)))
(types:hash-map (eval-hash-map ast env))
(types:any ast)))
@ -72,6 +81,7 @@
(defun eval-list (ast env)
(let ((forms (mal-data-value ast)))
(cond
((zerop (length forms)) ast)
((mal-data-value= mal-def! (first forms))
(env:set-env env (second forms) (mal-eval (third forms) env)))
((mal-data-value= mal-let* (first forms))
@ -83,7 +93,7 @@
(let ((predicate (mal-eval (second forms) env)))
(mal-eval (if (or (mal-data-value= predicate mal-nil)
(mal-data-value= predicate mal-false))
(fourth forms)
(or (fourth forms) mal-nil)
(third forms))
env)))
((mal-data-value= mal-fn* (first forms))
@ -93,7 +103,7 @@
(mal-eval body (env:create-mal-env :parent env
:binds (listify (mal-data-value arglist))
:exprs args))))))
(t (let* ((evaluated-list (eval-ast ast env))
(t (let* ((evaluated-list (eval-sequence 'list ast env))
(function (car evaluated-list)))
;; If first element is a mal function unwrap it
(apply (mal-data-value function)
@ -102,13 +112,6 @@
(defun mal-read (string)
(reader:read-str string))
(defun mal-eval (ast env)
(cond
((null ast) mal-nil)
((not (mal-list-p ast)) (eval-ast ast env))
((zerop (length (mal-data-value ast))) ast)
(t (eval-list ast env))))
(defun mal-print (expression)
(printer:pr-str expression))

43
impls/common-lisp/src/step5_tco.lisp
View File

@ -30,8 +30,8 @@
(defvar mal-if (make-mal-symbol "if"))
(defvar mal-fn* (make-mal-symbol "fn*"))
(defun eval-sequence (sequence env)
(map 'list
(defun eval-sequence (type sequence env)
(map type
(lambda (ast) (mal-eval ast env))
(mal-data-value sequence)))
@ -44,25 +44,31 @@
hash-map-value)
(make-mal-hash-map new-hash-table)))
(defun eval-ast (ast env)
(switch-mal-type ast
(types:symbol (env:get-env env ast))
(types:list (eval-sequence ast env))
(types:vector (make-mal-vector (apply 'vector (eval-sequence ast env))))
(types:hash-map (eval-hash-map ast env))
(types:any ast)))
(defun mal-read (string)
(reader:read-str string))
(defun mal-eval (ast env)
(loop
do (cond
((null ast) (return mal-nil))
((not (mal-list-p ast)) (return (eval-ast ast env)))
((zerop (length (mal-data-value ast))) (return ast))
(t (let ((forms (mal-data-value ast)))
do (let ((debug-eval (env:get-env env "DEBUG-EVAL")))
(when (and debug-eval
(not (mal-data-value= debug-eval mal-false))
(not (mal-data-value= debug-eval mal-false)))
(write-line (format nil "EVAL: ~a" (pr-str ast)))
(force-output *standard-output*)))
do (switch-mal-type ast
(types:symbol
(return
(let ((key (mal-data-value ast)))
(or (env:get-env env key)
(error 'undefined-symbol :symbol (format nil "~a" key))))))
(types:vector (return (make-mal-vector (eval-sequence 'vector ast env))))
(types:hash-map (return (eval-hash-map ast env)))
(types:list
(let ((forms (mal-data-value ast)))
(cond
((null forms)
(return ast))
((mal-data-value= mal-def! (first forms))
(return (env:set-env env (second forms) (mal-eval (third forms) env))))
@ -92,7 +98,7 @@
(let ((predicate (mal-eval (second forms) env)))
(setf ast (if (or (mal-data-value= predicate mal-nil)
(mal-data-value= predicate mal-false))
(fourth forms)
(or (fourth forms) mal-nil)
(third forms)))))
((mal-data-value= mal-fn* (first forms))
@ -106,7 +112,7 @@
(cons :ast body)
(cons :env env))))))
(t (let* ((evaluated-list (eval-ast ast env))
(t (let* ((evaluated-list (eval-sequence 'list ast env))
(function (car evaluated-list)))
;; If first element is a mal function unwrap it
(if (not (mal-fn-p function))
@ -118,7 +124,8 @@
:binds (map 'list
#'identity
(mal-data-value (cdr (assoc :params attrs))))
:exprs (cdr evaluated-list)))))))))))))
:exprs (cdr evaluated-list))))))))))
(types:any (return ast)))))
(defun mal-print (expression)
(printer:pr-str expression))

Some files were not shown because too many files have changed in this diff Show More