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

Improve conformity with the MAL process, performance and readability.

Browse Source 
Conformity:
Move readline to readline.ads and drop the Interactive_Loop subprogram.
Let the main Read and Print functions do input/output.
Rename environments.ads to envs.ads (the name of the eval parameter
seems more important).
Move association of formal and actual parameters to the env "constructor".
Use the documentation names whenever possible (especially, make calls
to Eval where they are expected and explicit the parameters).
Iterate on a NS structure provided by Core, as per the process.
Use similar method names for Envs.Ptr and Envs.Closure_Ptr,
as the difference is an implementation detail.

Performance:
Move Map into list methods, swap into atom methods.
Pass formal parameters as an array of symbols on the stack,
instead of a MAL list.

Readability:
Replace some one-letter names.
Use renamings when the lines become too long.
Split Pr_Str in small subprograms.
Declare the access to built-in functions in Types.Mal.
Consistent names.
Move redundant comments into README.
This commit is contained in:
Nicolas Boulenguez 2019-03-06 19:48:51 +01:00
parent 6e2b7ddffe
commit 11932a6c89
36 changed files with 1854 additions and 1720 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

23
ada2/Makefile
View File

@ -35,9 +35,11 @@ clean:
# Tell Make how to detect out-of-date executables, and let gnatmake do
# the rest when it must be executed.
TYPES := \
environments.ads environments.adb \
envs.ads envs.adb \
eval_cb.ads \
printer.ads printer.adb \
reader.ads reader.adb \
readline.ads \
types-atoms.ads types-atoms.adb \
types-builtins.ads types-builtins.adb \
types-functions.ads types-functions.adb \
@ -59,12 +61,13 @@ $(steps) :
.PHONY: steps.diff
steps.diff:
diff -u step1*.adb step2*.adb; \
diff -u step2*.adb step3*.adb; \
diff -u step3*.adb step4*.adb; \
diff -u step4*.adb step5*.adb; \
diff -u step5*.adb step6*.adb; \
diff -u step6*.adb step7*.adb; \
diff -u step7*.adb step8*.adb; \
diff -u step8*.adb step9*.adb; \
diff -u step9*.adb stepa*.adb || true
diff -u step0_*.adb step1_*.adb || true
diff -u step1_*.adb step2_*.adb || true
diff -u step2_*.adb step3_*.adb || true
diff -u step3_*.adb step4_*.adb || true
diff -u step4_*.adb step5_*.adb || true
diff -u step5_*.adb step6_*.adb || true
diff -u step6_*.adb step7_*.adb || true
diff -u step7_*.adb step8_*.adb || true
diff -u step8_*.adb step9_*.adb || true
diff -u step9_*.adb stepa_*.adb || true

20
ada2/README
View File

@ -1,15 +1,15 @@
Comparison with the first Ada implementation.
The first implementation was deliberately compatible with all Ada
compilers, while this one illustrates various Ada 2012 features, like
compilers, while this one illustrates various Ada 2012 features:
assertions, preconditions, invariants, initial assignment for limited
types, limited imports...
The variant MAL type is implemented with a discriminant instead of
object-style dispatching. This allows more static and dynamic checks,
but also two crucial performance improvements:
* Nil, boolean and integers are passed by value without dynamic
allocation.
* Nil, boolean, integers and built-in functions are passed by value
without dynamic allocation.
* Lists are implemented as C-style arrays, and most of them can be
allocated on the stack.
@ -24,18 +24,24 @@ bounds and discriminant consistency are only enabled during tests).
There are also similarities with the first implementation. For
example, both rely on user-defined finalization to handle recursive
structures without garbage collecting.
structures without garbage collecting. Also, most pointer types are
wrapped into a finalized type counting references.
Some remarks if anyone works on this.
About reference reference counting.
* The default value for such wrapped pointers is invalid, new
variables must be assigned immediately. This is usually enforced by
a hidden discriminant, but this would prevent the type to become a
field inside Types.Mal.T. So we usse a private invariant as a a
fallback.
* The finalize procedure may be called twice, so it does nothing when
the reference count is zero, meaning that we are reaching Finalize
recursively.
* In implementations, a consistent object (that will be deallocated
automatically) must be built before any exception is raised by user
code (for example 'map' may run user functions).
code (for example the 'map' built-in function may run user code).
Known bugs: the third step of the perf^ada2 target fails during the
final storage deallocation when the executable is built with -gnatp. I

426
ada2/core.adb
View File

@ -3,65 +3,63 @@ with Ada.Characters.Latin_1;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Environments; pragma Elaborate_All (Environments);
with Envs;
with Eval_Cb;
with Types.Atoms;
with Types.Builtins;
with Types.Functions;
with Types.Lists;
with Types.Maps;
with Types.Symbols.Names; pragma Elaborate_All (Types.Symbols);
with Types.Symbols.Names;
with Printer;
with Reader;
package body Core is
use Types;
use type Mal.T;
package ASU renames Ada.Strings.Unbounded;
-- Used by time_ms.
Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock;
function Apply_Helper (Func : in Mal.T;
Args : in Mal.T_Array;
Name : in String) return Mal.T with Inline;
-- If Func is not executable, report an exception using "name" as
-- the built-in function name.
-- In the following helpers, "name" is the one reported by error
-- messages.
generic
Kind : in Kind_Type;
Name : in String;
function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T;
function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1
then raise Argument_Error with Name & ": expects 1 argument"
else (Kind_Boolean, Args (Args'First).Kind = Kind));
is (if Args'Length /= 1 then
raise Argument_Error with Name & ": expects 1 argument"
else
(Kind_Boolean, Args (Args'First).Kind = Kind));
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
Name : in String;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2
then raise Argument_Error with Name & ": expects 2 arguments"
elsif (for some A of Args => A.Kind /= Kind_Number)
then raise Argument_Error with Name & ": expects numbers"
else (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number,
Args (Args'Last).Ada_Number)));
is (if Args'Length /= 2 then
raise Argument_Error with Name & ": expects 2 arguments"
elsif (for some A of Args => A.Kind /= Kind_Number) then
raise Argument_Error with Name & ": expects numbers"
else
(Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number)));
generic
with function Ada_Operator (Left, Right : in Integer) return Boolean;
Name : in String;
function Generic_Comparison (Args : in Mal.T_Array) return Mal.T;
function Generic_Comparison (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2
then raise Argument_Error with Name & ": expects 2 arguments"
elsif (for some A of Args => A.Kind /= Kind_Number)
then raise Argument_Error with Name & ": expects numbers"
else (Kind_Boolean, Ada_Operator (Args (Args'First).Ada_Number,
Args (Args'Last).Ada_Number)));
is (if Args'Length /= 2 then
raise Argument_Error with Name & ": expects 2 arguments"
elsif (for some A of Args => A.Kind /= Kind_Number) then
raise Argument_Error with Name & ": expects numbers"
else
(Kind_Boolean, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number)));
-- Built-in functions from this package.
function Addition is new Generic_Mal_Operator ("+", "+");
function Apply (Args : in Mal.T_Array) return Mal.T;
function Division is new Generic_Mal_Operator ("/", "/");
@ -86,7 +84,6 @@ package body Core is
function Keyword (Args : in Mal.T_Array) return Mal.T;
function Less_Equal is new Generic_Comparison ("<=", "<=");
function Less_Than is new Generic_Comparison ("<", "<");
function Map (Args : in Mal.T_Array) return Mal.T;
function Meta (Args : in Mal.T_Array) return Mal.T;
function Pr_Str (Args : in Mal.T_Array) return Mal.T;
function Println (Args : in Mal.T_Array) return Mal.T;
@ -98,7 +95,6 @@ package body Core is
function Slurp (Args : in Mal.T_Array) return Mal.T;
function Str (Args : in Mal.T_Array) return Mal.T;
function Subtraction is new Generic_Mal_Operator ("-", "-");
function Swap (Args : in Mal.T_Array) return Mal.T;
function Symbol (Args : in Mal.T_Array) return Mal.T;
function Throw (Args : in Mal.T_Array) return Mal.T;
function Time_Ms (Args : in Mal.T_Array) return Mal.T;
@ -106,58 +102,49 @@ package body Core is
----------------------------------------------------------------------
function Apply_Helper (Func : in Mal.T;
Args : in Mal.T_Array;
Name : in String) return Mal.T
is
begin
case Func.Kind is
when Kind_Builtin =>
return Func.Builtin.all (Args);
when Kind_Builtin_With_Meta =>
return Func.Builtin_With_Meta.Data.all (Args);
when Kind_Function =>
declare
Env : constant Environments.Ptr
:= Func.Function_Value.Closure.Closure_Sub;
begin
Func.Function_Value.Set_Binds (Env, Args);
return Eval_Ref.all (Func.Function_Value.Expression, Env);
end;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Symbol | Kind_Keyword | Kind_List | Kind_Vector | Kind_Map
| Kind_Macro =>
raise Argument_Error with Name & ": cannot execute "
& ASU.To_String (Printer.Pr_Str (Func));
end case;
end Apply_Helper;
function Apply (Args : in Mal.T_Array) return Mal.T is
use type Lists.Ptr;
begin
if Args'Length < 2 then
raise Argument_Error with "apply: expects at least 2 arguments";
elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "apply: last arg must a be list or vector";
else
return Apply_Helper (Args (Args'First),
Args (Args'First + 1 .. Args'Last - 1)
& Args (Args'Last).L,
"apply");
raise Argument_Error with "apply: last arg must be a list or vector";
end if;
declare
F : Mal.T renames Args (Args'First);
A : constant Mal.T_Array
:= Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).List;
begin
case F.Kind is
when Kind_Builtin =>
return F.Builtin.all (A);
when Kind_Builtin_With_Meta =>
return F.Builtin_With_Meta.Builtin.all (A);
when Kind_Function =>
return F.Fn.Apply (A);
when others =>
raise Argument_Error
with "apply: cannot call " & Printer.Img (F);
end case;
end;
end Apply;
function Equals (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2 then
raise Argument_Error with "=: expects 2 arguments"
else
(Kind_Boolean, Args (Args'First) = Args (Args'Last)));
function Equals (Args : in Mal.T_Array) return Mal.T is
use type Mal.T;
begin
if Args'Length /= 2 then
raise Argument_Error with "=: expects 2 arguments";
else
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
end if;
end Equals;
function Eval (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "eval: expects 1 argument"
else
Eval_Ref.all (Args (Args'First), Environments.Repl));
Eval_Cb.Cb.all (Ast => Args (Args'First),
Env => Envs.Repl));
function Is_False (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
@ -193,81 +180,136 @@ package body Core is
else
(Kind_Keyword, Args (Args'First).S));
function Map (Args : in Mal.T_Array) return Mal.T is
function Meta (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 2 then
raise Argument_Error with "map: expects 2 arguments";
elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "map: arg 2 must be a list or vector";
if Args'Length /= 1 then
raise Argument_Error with "meta: expects 1 argument";
end if;
declare
R : Mal.T_Array (1 .. Args (Args'Last).L.Length);
A1 : Mal.T renames Args (Args'First);
begin
for I in R'Range loop
R (I) := Apply_Helper (Args (Args'First),
Mal.T_Array'(1 => Args (Args'Last).L.Element (I)),
"map");
end loop;
return Lists.List (R);
end;
end Map;
function Meta (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "meta: expects 1 argument"
else
(case Args (Args'First).Kind is
case A1.Kind is
when Kind_List | Kind_Vector =>
Args (Args'First).L.Meta,
return A1.List.Meta;
when Kind_Map =>
Args (Args'First).Map.Meta,
return A1.Map.Meta;
when Kind_Function =>
Args (Args'First).Function_Value.Meta,
return A1.Fn.Meta;
when Kind_Builtin_With_Meta =>
Args (Args'First).Builtin_With_Meta.Meta,
return A1.Builtin_With_Meta.Meta;
when Kind_Builtin =>
Mal.Nil,
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number |
Kind_String | Kind_Symbol | Kind_Keyword | Kind_Macro =>
return Mal.Nil;
when others =>
raise Argument_Error
with "meta: expects a list, vector, map or function"));
with "meta: expects a list, vector, map or function";
end case;
end;
end Meta;
function Ns return Binding_List
is ((Symbols.Constructor ("+"), Addition'Access),
(Symbols.Constructor ("apply"), Apply'Access),
(Symbols.Constructor ("assoc"), Maps.Assoc'Access),
(Symbols.Constructor ("atom"), Atoms.Atom'Access),
(Symbols.Constructor ("concat"), Lists.Concat'Access),
(Symbols.Constructor ("conj"), Lists.Conj'Access),
(Symbols.Constructor ("cons"), Lists.Cons'Access),
(Symbols.Constructor ("contains?"), Maps.Contains'Access),
(Symbols.Constructor ("count"), Lists.Count'Access),
(Symbols.Names.Deref, Atoms.Deref'Access),
(Symbols.Constructor ("dissoc"), Maps.Dissoc'Access),
(Symbols.Constructor ("/"), Division'Access),
(Symbols.Constructor ("="), Equals'Access),
(Symbols.Constructor ("eval"), Eval'Access),
(Symbols.Constructor ("first"), Lists.First'Access),
(Symbols.Constructor ("get"), Maps.Get'Access),
(Symbols.Constructor (">="), Greater_Equal'Access),
(Symbols.Constructor (">"), Greater_Than'Access),
(Symbols.Constructor ("hash-map"), Maps.Hash_Map'Access),
(Symbols.Constructor ("atom?"), Is_Atom'Access),
(Symbols.Constructor ("empty?"), Lists.Is_Empty'Access),
(Symbols.Constructor ("false?"), Is_False'Access),
(Symbols.Constructor ("fn?"), Is_Function'Access),
(Symbols.Constructor ("keyword?"), Is_Keyword'Access),
(Symbols.Constructor ("list?"), Is_List'Access),
(Symbols.Constructor ("macro?"), Is_Macro'Access),
(Symbols.Constructor ("map?"), Is_Map'Access),
(Symbols.Constructor ("nil?"), Is_Nil'Access),
(Symbols.Constructor ("number?"), Is_Number'Access),
(Symbols.Constructor ("sequential?"), Is_Sequential'Access),
(Symbols.Constructor ("string?"), Is_String'Access),
(Symbols.Constructor ("symbol?"), Is_Symbol'Access),
(Symbols.Constructor ("true?"), Is_True'Access),
(Symbols.Constructor ("vector?"), Is_Vector'Access),
(Symbols.Constructor ("keys"), Maps.Keys'Access),
(Symbols.Constructor ("keyword"), Keyword'Access),
(Symbols.Constructor ("<="), Less_Equal'Access),
(Symbols.Constructor ("<"), Less_Than'Access),
(Symbols.Constructor ("list"), Lists.List'Access),
(Symbols.Constructor ("map"), Lists.Map'Access),
(Symbols.Constructor ("meta"), Meta'Access),
(Symbols.Constructor ("nth"), Lists.Nth'Access),
(Symbols.Constructor ("pr-str"), Pr_Str'Access),
(Symbols.Constructor ("println"), Println'Access),
(Symbols.Constructor ("prn"), Prn'Access),
(Symbols.Constructor ("*"), Product'Access),
(Symbols.Constructor ("read-string"), Read_String'Access),
(Symbols.Constructor ("readline"), Readline'Access),
(Symbols.Constructor ("reset!"), Atoms.Reset'Access),
(Symbols.Constructor ("rest"), Lists.Rest'Access),
(Symbols.Constructor ("seq"), Seq'Access),
(Symbols.Constructor ("slurp"), Slurp'Access),
(Symbols.Constructor ("str"), Str'Access),
(Symbols.Constructor ("-"), Subtraction'Access),
(Symbols.Constructor ("swap!"), Atoms.Swap'Access),
(Symbols.Constructor ("symbol"), Symbol'Access),
(Symbols.Constructor ("throw"), Throw'Access),
(Symbols.Constructor ("time-ms"), Time_Ms'Access),
(Symbols.Constructor ("vals"), Maps.Vals'Access),
(Symbols.Constructor ("vector"), Lists.Vector'Access),
(Symbols.Names.With_Meta, With_Meta'Access));
function Pr_Str (Args : in Mal.T_Array) return Mal.T is
R : ASU.Unbounded_String := ASU.Null_Unbounded_String;
Started : Boolean := False;
begin
return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do
if 0 < Args'Length then
ASU.Append (R.S, Printer.Pr_Str (Args (Args'First)));
for I in Args'First + 1 .. Args'Last loop
ASU.Append (R.S, ' ');
ASU.Append (R.S, Printer.Pr_Str (Args (I)));
end loop;
for A of Args loop
if Started then
ASU.Append (R, ' ');
else
Started := True;
end if;
end return;
ASU.Append (R, Printer.Pr_Str (A));
end loop;
return (Kind_String, R);
end Pr_Str;
function Println (Args : in Mal.T_Array) return Mal.T is
use Ada.Text_IO.Unbounded_IO;
Started : Boolean := False;
begin
if 0 < Args'Length then
Put (Printer.Pr_Str (Args (Args'First), Readably => False));
for I in Args'First + 1 .. Args'Last loop
for A of Args loop
if Started then
Ada.Text_IO.Put (' ');
Put (Printer.Pr_Str (Args (I), Readably => False));
end loop;
end if;
else
Started := True;
end if;
Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A, Readably => False));
end loop;
Ada.Text_IO.New_Line;
return Mal.Nil;
end Println;
function Prn (Args : in Mal.T_Array) return Mal.T is
Started : Boolean := False;
begin
if 0 < Args'Length then
Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (Args'First)));
for I in Args'First + 1 .. Args'Last loop
for A of Args loop
if Started then
Ada.Text_IO.Put (' ');
Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (I)));
end loop;
end if;
else
Started := True;
end if;
Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (A));
end loop;
Ada.Text_IO.New_Line;
return Mal.Nil;
end Prn;
@ -278,13 +320,12 @@ package body Core is
raise Argument_Error with "readline: expects 1 argument";
elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then
raise Argument_Error with "readline: expects a keyword or string";
end if;
Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S);
if Ada.Text_IO.End_Of_File then
return Mal.Nil;
else
Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S);
if Ada.Text_IO.End_Of_File then
return Mal.Nil;
else
return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line);
end if;
return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line);
end if;
end Readline;
@ -319,10 +360,10 @@ package body Core is
end;
end if;
when Kind_List | Kind_Vector =>
if Args (Args'First).L.Length = 0 then
if Args (Args'First).List.Length = 0 then
return Mal.Nil;
else
return (Kind_List, Args (Args'First).L);
return (Kind_List, Args (Args'First).List);
end if;
when others =>
raise Argument_Error with "seq: expects a string, list or vector";
@ -354,32 +395,14 @@ package body Core is
end Slurp;
function Str (Args : in Mal.T_Array) return Mal.T is
R : ASU.Unbounded_String := ASU.Null_Unbounded_String;
begin
return R : Mal.T := (Kind_String, ASU.Null_Unbounded_String) do
for Arg of Args loop
ASU.Append (R.S, Printer.Pr_Str (Arg, Readably => False));
end loop;
end return;
for A of Args loop
ASU.Append (R, Printer.Pr_Str (A, Readably => False));
end loop;
return (Kind_String, R);
end Str;
function Swap (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length < 2 then
raise Argument_Error with "swap!: expects at least 2 arguments";
elsif Args (Args'First).Kind /= Kind_Atom then
raise Argument_Error with "swap!: arg 1 must be an atom";
end if;
declare
use type Mal.T_Array;
X : Mal.T renames Atoms.Deref (Args (Args'First .. Args'First));
FX : Mal.T renames Apply_Helper (Args (Args'First + 1),
X & Args (Args'First + 2 .. Args'Last),
"swap!");
begin
return Atoms.Reset (Mal.T_Array'(Args (Args'First), FX));
end;
end Swap;
function Symbol (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "symbol?: expects 1 argument"
@ -407,88 +430,33 @@ package body Core is
Integer (1000.0 * (Ada.Calendar.Clock - Start_Time)));
end Time_Ms;
function With_Meta (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2 then
raise Argument_Error with "with-meta: expects 2 arguments"
else (case Args (Args'First).Kind is
when Kind_Builtin_With_Meta =>
Args (Args'First).Builtin_With_Meta.With_Meta (Args (Args'Last)),
when Kind_Builtin =>
Builtins.With_Meta (Args (Args'First).Builtin, Args (Args'Last)),
when Kind_List =>
(Kind_List, Args (Args'First).L.With_Meta (Args (Args'Last))),
when Kind_Vector =>
(Kind_Vector, Args (Args'First).L.With_Meta (Args (Args'Last))),
when Kind_Map =>
Args (Args'First).Map.With_Meta (Args (Args'Last)),
when Kind_Function =>
Args (Args'First).Function_Value.With_Meta (Args (Args'Last)),
when others =>
Args (Args'First)));
function With_Meta (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 2 then
raise Argument_Error with "with-meta: expects 2 arguments";
end if;
declare
A1 : Mal.T renames Args (Args'First);
A2 : Mal.T renames Args (Args'Last);
begin
case A1.Kind is
when Kind_Builtin_With_Meta =>
return A1.Builtin_With_Meta.With_Meta (A2);
when Kind_Builtin =>
return Builtins.With_Meta (A1.Builtin, A2);
when Kind_List =>
return (Kind_List, A1.List.With_Meta (A2));
when Kind_Vector =>
return (Kind_Vector, A1.List.With_Meta (A2));
when Kind_Map =>
return A1.Map.With_Meta (A2);
when Kind_Function =>
return A1.Fn.With_Meta (A2);
when others =>
raise Argument_Error
with "with-meta: expects a list, vector, map or function";
end case;
end;
end With_Meta;
use Symbols;
R : Environments.Ptr renames Environments.Repl;
B : Kind_Type renames Kind_Builtin;
begin -- Core
R.Set (Constructor ("+"), (B, Addition'Access));
R.Set (Constructor ("apply"), (B, Apply'Access));
R.Set (Constructor ("assoc"), (B, Maps.Assoc'Access));
R.Set (Constructor ("atom"), (B, Atoms.Atom'Access));
R.Set (Constructor ("concat"), (B, Lists.Concat'Access));
R.Set (Constructor ("conj"), (B, Lists.Conj'Access));
R.Set (Constructor ("cons"), (B, Lists.Cons'Access));
R.Set (Constructor ("contains?"), (B, Maps.Contains'Access));
R.Set (Constructor ("count"), (B, Lists.Count'Access));
R.Set (Names.Deref, (B, Atoms.Deref'Access));
R.Set (Constructor ("dissoc"), (B, Maps.Dissoc'Access));
R.Set (Constructor ("/"), (B, Division'Access));
R.Set (Constructor ("="), (B, Equals'Access));
R.Set (Constructor ("eval"), (B, Eval'Access));
R.Set (Constructor ("first"), (B, Lists.First'Access));
R.Set (Constructor ("get"), (B, Maps.Get'Access));
R.Set (Constructor (">="), (B, Greater_Equal'Access));
R.Set (Constructor (">"), (B, Greater_Than'Access));
R.Set (Constructor ("hash-map"), (B, Maps.Hash_Map'Access));
R.Set (Constructor ("atom?"), (B, Is_Atom'Access));
R.Set (Constructor ("empty?"), (B, Lists.Is_Empty'Access));
R.Set (Constructor ("false?"), (B, Is_False'Access));
R.Set (Constructor ("fn?"), (B, Is_Function'Access));
R.Set (Constructor ("keyword?"), (B, Is_Keyword'Access));
R.Set (Constructor ("list?"), (B, Is_List'Access));
R.Set (Constructor ("macro?"), (B, Is_Macro'Access));
R.Set (Constructor ("map?"), (B, Is_Map'Access));
R.Set (Constructor ("nil?"), (B, Is_Nil'Access));
R.Set (Constructor ("number?"), (B, Is_Number'Access));
R.Set (Constructor ("sequential?"), (B, Is_Sequential'Access));
R.Set (Constructor ("string?"), (B, Is_String'Access));
R.Set (Constructor ("symbol?"), (B, Is_Symbol'Access));
R.Set (Constructor ("true?"), (B, Is_True'Access));
R.Set (Constructor ("vector?"), (B, Is_Vector'Access));
R.Set (Constructor ("keys"), (B, Maps.Keys'Access));
R.Set (Constructor ("keyword"), (B, Keyword'Access));
R.Set (Constructor ("<="), (B, Less_Equal'Access));
R.Set (Constructor ("<"), (B, Less_Than'Access));
R.Set (Constructor ("list"), (B, Lists.List'Access));
R.Set (Constructor ("map"), (B, Map'Access));
R.Set (Constructor ("meta"), (B, Meta'Access));
R.Set (Constructor ("nth"), (B, Lists.Nth'Access));
R.Set (Constructor ("pr-str"), (B, Pr_Str'Access));
R.Set (Constructor ("println"), (B, Println'Access));
R.Set (Constructor ("prn"), (B, Prn'Access));
R.Set (Constructor ("*"), (B, Product'Access));
R.Set (Constructor ("read-string"), (B, Read_String'Access));
R.Set (Constructor ("readline"), (B, Readline'Access));
R.Set (Constructor ("reset!"), (B, Atoms.Reset'Access));
R.Set (Constructor ("rest"), (B, Lists.Rest'Access));
R.Set (Constructor ("seq"), (B, Seq'Access));
R.Set (Constructor ("slurp"), (B, Slurp'Access));
R.Set (Constructor ("str"), (B, Str'Access));
R.Set (Constructor ("-"), (B, Subtraction'Access));
R.Set (Constructor ("swap!"), (B, Swap'Access));
R.Set (Constructor ("symbol"), (B, Symbol'Access));
R.Set (Constructor ("throw"), (B, Throw'Access));
R.Set (Constructor ("time-ms"), (B, Time_Ms'Access));
R.Set (Constructor ("vals"), (B, Maps.Vals'Access));
R.Set (Constructor ("vector"), (B, Lists.Vector'Access));
R.Set (Names.With_Meta, (B, With_Meta'Access));
end Core;

24
ada2/core.ads
View File

@ -1,19 +1,23 @@
limited with Environments;
with Types.Symbols;
with Types.Mal;
package Core with Elaborate_Body is
-- Initialization of this package fills Environments.Repl with
-- built-in functions.
type Binding is record
Symbol : Types.Symbols.Ptr;
Builtin : Types.Mal.Builtin_Ptr;
end record;
Eval_Ref : access function (Ast : in Types.Mal.T;
Env : in Environments.Ptr)
return Types.Mal.T;
-- Set by the main program at startup.
type Binding_List is array (Positive range <>) of Binding;
function Ns return Binding_List;
-- A list of built-in symbols and functionse.
-- A constant would make sense, but
-- * implementing it in the private part
Exception_Throwed : exception;
Last_Exception : Types.Mal.T := (Kind => Types.Kind_Nil);
-- When the exception is throwed, Last_Exception is set with the
-- related Data.
Last_Exception : Types.Mal.T := Types.Mal.Nil;
-- When the "throw" builtin is executed, it assigns its argument
-- to Last_Exception, then raises this Ada exception.
end Core;

131
ada2/environments.adb → ada2/envs.adb
View File

@ -1,7 +1,9 @@
with Ada.Containers.Hashed_Maps;
with Ada.Unchecked_Deallocation;
package body Environments is
with Types.Symbols.Names;
package body Envs is
use Types;
@ -63,6 +65,18 @@ package body Environments is
procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access);
procedure Unreference (Reference : in out Heap_Access);
procedure Set_Binds (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
with Inline;
procedure Set_Binds_Macro (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Lists.Ptr)
with Inline;
-- These two procedures are redundant, but sharing the code would
-- be ugly or inefficient. They are separated as inline procedures
-- in order to ease comparison, though.
----------------------------------------------------------------------
procedure Adjust (Object : in out Closure_Ptr) is
@ -72,18 +86,6 @@ package body Environments is
end if;
end Adjust;
function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr is
begin
Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1;
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_On_Stack => False,
Outer_Ref => Outer.Ref,
others => <>);
return (Ada.Finalization.Limited_Controlled with Top);
end Closure_Sub;
function Copy_Pointer (Env : in Ptr) return Ptr is
begin
Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1;
@ -231,10 +233,10 @@ package body Environments is
end if;
end Finalize;
function Get (Env : in Ptr;
Key : in Symbols.Ptr)
return Mal.T is
Index : Stack_Index := Env.Index;
function Get (Evt : in Ptr;
Key : in Symbols.Ptr) return Mal.T
is
Index : Stack_Index := Evt.Index;
Ref : Heap_Access;
Definition : HM.Cursor;
begin
@ -291,9 +293,16 @@ package body Environments is
-- unreferenced alias if any.
end Replace_With_Sub;
procedure Replace_With_Closure_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class) is
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
is
begin
-- Finalize Env before creating the new environment, in case
-- this is the last reference and it can be forgotten.
-- Automatic assignment would construct the new value before
-- finalizing the old one (because this is safer in general).
Finalize (Env);
Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1;
Top := Top + 1;
@ -303,7 +312,9 @@ package body Environments is
Outer_Ref => Outer.Ref,
others => <>);
Env.Index := Top;
end Replace_With_Closure_Sub;
-- Now we can afford raising exceptions.
Set_Binds (Stack (Top).Data, Binds, Exprs);
end Replace_With_Sub;
procedure Set (Env : in Ptr;
Key : in Symbols.Ptr;
@ -312,7 +323,61 @@ package body Environments is
Stack (Env.Index).Data.Include (Key, New_Element);
end Set;
function Sub (Outer : in Ptr) return Ptr is
procedure Set_Binds (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
is
use type Symbols.Ptr;
Varargs : constant Boolean := 1 < Binds'Length and then
Binds (Binds'Last - 1) = Symbols.Names.Ampersand;
begin
if (if Varargs then
Exprs'Length < Binds'Length - 2
else
Exprs'Length /= Binds'Length)
then
raise Argument_Error with "user function expected "
& Symbols.To_String (Binds) & ", got"
& Integer'Image (Exprs'Length) & " actual parameters";
end if;
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop
M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I));
end loop;
if Varargs then
M.Include (Binds (Binds'Last),
Lists.List (Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
end if;
end Set_Binds;
procedure Set_Binds_Macro (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Lists.Ptr)
is
use type Symbols.Ptr;
Varargs : constant Boolean := 1 < Binds'Length and then
Binds (Binds'Last - 1) = Symbols.Names.Ampersand;
begin
if (if Varargs then
Exprs.Length - 1 < Binds'Length - 2
else
Exprs.Length - 1 /= Binds'Length)
then
raise Argument_Error with "macro expected "
& Symbols.To_String (Binds) & ", got"
& Integer'Image (Exprs.Length - 1) & "actual parameters";
end if;
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop
M.Include (Binds (Binds'First + I), Exprs.Element (2 + I));
end loop;
if Varargs then
M.Include (Binds (Binds'Last), Exprs.Slice (Start => Binds'Length));
end if;
end Set_Binds_Macro;
function Sub (Outer : in Ptr;
Binds : in Symbols.Symbol_Array;
Exprs : in Lists.Ptr) return Ptr
is
R : Stack_Record renames Stack (Outer.Index);
begin
R.Refs := R.Refs + 1;
@ -321,9 +386,31 @@ package body Environments is
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_Index => Outer.Index,
others => <>);
Set_Binds_Macro (Stack (Top).Data, Binds, Exprs);
return (Ada.Finalization.Limited_Controlled with Top);
end Sub;
function Sub (Outer : in Closure_Ptr'Class;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array) return Ptr
is
begin
Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1;
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_On_Stack => False,
Outer_Ref => Outer.Ref,
others => <>);
-- Take care to construct the result before raising any
-- exception, so that it is finalized correctly.
return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top)
do
-- Now we can afford raising exceptions.
Set_Binds (Stack (Top).Data, Binds, Exprs);
end return;
end Sub;
procedure Unreference (Reference : in out Heap_Access) is
Ref : Heap_Access := Reference;
begin
@ -345,4 +432,4 @@ package body Environments is
end loop;
end Unreference;
end Environments;
end Envs;

56
ada2/environments.ads → ada2/envs.ads
View File

@ -1,9 +1,14 @@
private with Ada.Finalization;
with Types.Lists;
with Types.Mal;
with Types.Symbols;
package Environments with Elaborate_Body is
package Envs with Elaborate_Body is
-- This package should be named Env, but Ada does not allow formal
-- parameters to be named like a package dependency, and it seems
-- that readability inside Eval is more important.
-- This implementation relies on the fact that the caller only
-- ever references environments in its execution stack.
@ -32,22 +37,24 @@ package Environments with Elaborate_Body is
-- The top environment.
function Copy_Pointer (Env : in Ptr) return Ptr with Inline;
function Sub (Outer : in Ptr) return Ptr with Inline;
-- Allows assignment to a freshly created variable. This is
-- required for tail call optimization, but should be avoided
-- elsewhere.
procedure Replace_With_Sub (Env : in out Ptr) with Inline;
-- Like Env := Sub (Outer => Env); except that Env is finalized
-- *before* the assignement, so its memory may be reused by the
-- new environment.
-- Equivalent to Env := Sub (Outer => Env, empty Binds and Exprs),
-- except that such an assignment is forbidden for performance
-- reasons.
procedure Set (Env : in Ptr;
Key : in Types.Symbols.Ptr;
New_Element : in Types.Mal.T)
with Inline;
function Get (Env : in Ptr;
Key : in Types.Symbols.Ptr)
return Types.Mal.T;
-- The Find method is merged into the Get method.
function Get (Evt : in Ptr;
Key : in Types.Symbols.Ptr) return Types.Mal.T;
Unknown_Key : exception;
-- Function closures.
@ -55,16 +62,33 @@ package Environments with Elaborate_Body is
type Closure_Ptr is tagged private;
Null_Closure : constant Closure_Ptr;
function Closure_Sub (Outer : in Closure_Ptr'Class) return Ptr;
procedure Replace_With_Closure_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class);
-- Like Env := Closure_Sub (Outer); except that the type is limited.
function New_Closure (Env : in Ptr'Class) return Closure_Ptr;
-- The class-wide argument does not make much sense, but avoids
-- the compiler wondering on which type is should dispatch.
function Sub (Outer : in Closure_Ptr'Class;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array) return Ptr;
-- Construct a new environment with the given closure as outer parent.
-- Then call Set with the paired elements of Binds and Exprs,
-- handling the "&" special formal parameter if present.
-- May raise Argument_Count.
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array);
-- Equivalent to Env := Sub (Outer, Binds, Expr); except that such
-- an assignment is forbidden for performance reasons.
function Sub (Outer : in Ptr;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Lists.Ptr) return Ptr;
-- Like Sub above, but dedicated to macros.
-- * The Outer parameter is the current environment, not a closure.
-- * The Exprs argument is a list.
-- * Its first element is skipped.
private
-- There must be a reference level so that functions may keep
@ -110,4 +134,4 @@ private
Null_Closure : constant Closure_Ptr
:= (Ada.Finalization.Controlled with null);
end Environments;
end Envs;

11
ada2/eval_cb.ads Normal file
View File

@ -0,0 +1,11 @@
with Envs;
with Types.Mal;
package Eval_Cb is
Cb : access function (Ast : in Types.Mal.T;
Env : in Envs.Ptr) return Types.Mal.T;
-- The main program must register this global callback to the main
-- eval function before some built-in functions are executed.
end Eval_Cb;

194
ada2/printer.adb
View File

@ -2,45 +2,37 @@ with Ada.Characters.Latin_1;
with Types.Atoms;
with Types.Functions;
with Types.Symbols;
with Types.Lists;
with Types.Maps;
package body Printer is
function Pr_Str (Ast : in Types.Mal.T;
Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
use Ada.Strings.Unbounded;
use Types;
function Pr_Str (Ast : in Mal.T;
Readably : in Boolean := True) return Unbounded_String
is
use Ada.Strings.Unbounded;
use Types;
Buffer : Unbounded_String := Null_Unbounded_String;
-- is appended the result character after character.
procedure Print_Form (Form_Ast : in Mal.T);
-- The recursive function traversing Ast for Pr_Str.
-- Form_Ast is the current node.
-- Helpers for Print_Form.
procedure Print_Number (Number : in Integer) with Inline;
procedure Print_List (List : in Lists.Ptr) with Inline;
procedure Print_Map (Map : in Maps.Ptr) with Inline;
procedure Print_Readably (S : in Unbounded_String) with Inline;
procedure Print_Symbols (List : in Symbols.Symbol_Array) with Inline;
Buffer : Unbounded_String := Null_Unbounded_String;
-- is appended the result character after character.
----------------------------------------------------------------------
procedure Print_Form (Form_Ast : in Mal.T) is
procedure Print_List (List : in Lists.Ptr) with Inline;
-- An helper for Print_Form.
procedure Print_List (List : in Lists.Ptr) is
begin
if 0 < List.Length then
Print_Form (List.Element (1));
for I in 2 .. List.Length loop
Append (Buffer, ' ');
Print_Form (List.Element (I));
end loop;
end if;
end Print_List;
begin -- Print_Form
begin
case Form_Ast.Kind is
when Kind_Nil =>
Append (Buffer, "nil");
@ -53,94 +45,128 @@ package body Printer is
when Kind_Symbol =>
Append (Buffer, Form_Ast.Symbol.To_String);
when Kind_Number =>
declare
Img : constant String := Integer'Image (Form_Ast.Ada_Number);
F : Positive := Img'First;
begin
if Img (F) = ' ' then
F := F + 1;
end if;
Append (Buffer, Img (F .. Img'Last));
end;
Print_Number (Form_Ast.Number);
when Kind_Keyword =>
Append (Buffer, ':');
Append (Buffer, Form_Ast.S);
when Kind_String =>
if Readably then
declare
C : Character;
begin
Append (Buffer, '"');
for I in 1 .. Length (Form_Ast.S) loop
C := Element (Form_Ast.S, I);
case C is
when '"' | '\' =>
Append (Buffer, '\');
Append (Buffer, C);
when Ada.Characters.Latin_1.LF =>
Append (Buffer, "\n");
when others =>
Append (Buffer, C);
end case;
end loop;
Append (Buffer, '"');
end;
Append (Buffer, '"');
Print_Readably (Form_Ast.S);
Append (Buffer, '"');
else
Append (Buffer, Form_Ast.S);
end if;
when Kind_List =>
Append (Buffer, '(');
Print_List (Form_Ast.L);
Print_List (Form_Ast.List);
Append (Buffer, ')');
when Kind_Vector =>
Append (Buffer, '[');
Print_List (Form_Ast.L);
Print_List (Form_Ast.List);
Append (Buffer, ']');
when Kind_Map =>
Append (Buffer, '{');
declare
Is_First : Boolean := True;
procedure Process (Key : in Mal.T;
Element : in Mal.T);
procedure Iterate is new Maps.Iterate (Process);
procedure Process (Key : in Mal.T;
Element : in Mal.T)
is
begin
if Is_First then
Is_First := False;
else
Append (Buffer, ' ');
end if;
Print_Form (Key);
Append (Buffer, ' ');
Print_Form (Element);
end Process;
begin
Iterate (Form_Ast.Map);
end;
Print_Map (Form_Ast.Map);
Append (Buffer, '}');
when Kind_Builtin | Kind_Builtin_With_Meta =>
Append (Buffer, "#<built-in>");
when Kind_Function =>
Append (Buffer, "#<function ");
Print_List (Form_Ast.Function_Value.Formals);
Append (Buffer, " -> ");
Print_Form (Form_Ast.Function_Value.Expression);
Append (Buffer, "#<function (");
Print_Symbols (Form_Ast.Fn.Params);
Append (Buffer, ") -> ");
Print_Form (Form_Ast.Fn.Ast);
Append (Buffer, '>');
when Kind_Macro =>
Append (Buffer, "#<macro ");
Print_List (Form_Ast.Function_Value.Formals);
Append (Buffer, " -> ");
Print_Form (Form_Ast.Function_Value.Expression);
Append (Buffer, "#<macro (");
Print_Symbols (Form_Ast.Fn.Params);
Append (Buffer, ") -> ");
Print_Form (Form_Ast.Fn.Ast);
Append (Buffer, '>');
when Kind_Atom =>
Append (Buffer, "(atom ");
Print_Form (Atoms.Deref (Mal.T_Array'(1 => Form_Ast)));
Print_Form (Atoms.Deref (Form_Ast.Atom));
Append (Buffer, ')');
end case;
end Print_Form;
procedure Print_List (List : in Lists.Ptr) is
Started : Boolean := False;
begin
for I in 1 .. List.Length loop
if Started then
Append (Buffer, ' ');
else
Started := True;
end if;
Print_Form (List.Element (I));
end loop;
end Print_List;
procedure Print_Map (Map : in Maps.Ptr) is
procedure Process (Key : in Mal.T;
Element : in Mal.T);
procedure Iterate is new Maps.Iterate (Process);
Started : Boolean := False;
procedure Process (Key : in Mal.T;
Element : in Mal.T)
is
begin
if Started then
Append (Buffer, ' ');
else
Started := True;
end if;
Print_Form (Key);
Append (Buffer, ' ');
Print_Form (Element);
end Process;
begin
Iterate (Map);
end Print_Map;
procedure Print_Number (Number : in Integer) is
Image : constant String := Integer'Image (Number);
First : Positive := Image'First;
begin
if Image (First) = ' ' then
First := First + 1;
end if;
Append (Buffer, Image (First .. Image'Last));
end Print_Number;
procedure Print_Readably (S : in Unbounded_String) is
begin
for I in 1 .. Length (S) loop
declare
C : constant Character := Element (S, I);
begin
case C is
when '"' | '\' =>
Append (Buffer, '\');
Append (Buffer, C);
when Ada.Characters.Latin_1.LF =>
Append (Buffer, "\n");
when others =>
Append (Buffer, C);
end case;
end;
end loop;
end Print_Readably;
procedure Print_Symbols (List : in Symbols.Symbol_Array) is
Started : Boolean := False;
begin
for S of List loop
if Started then
Append (Buffer, ' ');
else
Started := True;
end if;
Append (Buffer, S.To_String);
end loop;
end Print_Symbols;
----------------------------------------------------------------------
begin -- Pr_Str

5
ada2/printer.ads
View File

@ -8,4 +8,9 @@ package Printer with Elaborate_Body is
Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String;
function Img (Ast : in Types.Mal.T) return String
is (Ada.Strings.Unbounded.To_String (Pr_Str (Ast))) with Inline;
-- This form is convenient for reporting errors, but the
-- conversion should be avoided when possible.
end Printer;

3
ada2/reader.adb
View File

@ -25,8 +25,7 @@ package body Reader is
----------------------------------------------------------------------
procedure Find_Next_Token
is
procedure Find_Next_Token is
use Ada.Characters.Latin_1;
begin
First := Last + 1;

32
ada2/readline.adb Normal file
View File

@ -0,0 +1,32 @@
with Interfaces.C.Strings;
package body Readline is
function Input (Prompt : in String) return String is
use Interfaces.C;
use Interfaces.C.Strings;
function C_Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
C_Line : constant chars_ptr := C_Readline (To_C (Prompt));
begin
if C_Line = Null_Ptr then
raise End_Of_File;
end if;
return Ada_Line : constant String := Value (C_Line) do
if Ada_Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
end return;
end Input;
end Readline;

7
ada2/readline.ads Normal file
View File

@ -0,0 +1,7 @@
package Readline with Preelaborate is
function Input (Prompt : in String) return String;
End_Of_File : exception;
end Readline;

66
ada2/step0_repl.adb
View File

@ -1,55 +1,43 @@
with Ada.Text_IO;
with Interfaces.C.Strings;
with Readline;
procedure Step0_Repl is
subtype Mal_Type is String;
function Read return String with Inline;
function Read (Source : in String) return Mal_Type
is (Source);
function Eval (Ast : in String) return String;
function Eval (Ast : in Mal_Type) return Mal_Type
is (Ast);
procedure Print (Ast : in String) with Inline;
function Print (Ast : in Mal_Type) return String
is (Ast);
function Rep (Source : in String) return String
is (Print (Eval (Read (Source)))) with Inline;
procedure Interactive_Loop;
procedure Rep with Inline;
----------------------------------------------------------------------
procedure Interactive_Loop is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
function Eval (Ast : in String) return String is (Ast);
procedure Print (Ast : in String) is
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Put_Line (Rep (Line));
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
Ada.Text_IO.Put_Line (Ast);
end Print;
function Read return String is (Readline.Input ("user> "));
procedure Rep is
begin
Print (Eval (Read));
end Rep;
----------------------------------------------------------------------
begin
Interactive_Loop;
loop
begin
Rep;
exception
when Readline.End_Of_File =>
exit;
end;
end loop;
Ada.Text_IO.New_Line;
end Step0_Repl;

77
ada2/step1_read_print.adb
View File

@ -1,69 +1,54 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Printer;
with Reader;
with Readline;
with Types.Mal;
procedure Step1_Read_Print is
package ASU renames Ada.Strings.Unbounded;
use Types;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast : in Mal.T) return Mal.T
is (Ast);
function Eval (Ast : in Mal.T) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String) return ASU.Unbounded_String
is (Print (Eval (Read (Source)))) with Inline;
procedure Interactive_Loop;
procedure Rep with Inline;
----------------------------------------------------------------------
procedure Interactive_Loop is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
function Eval (Ast : in Mal.T) return Mal.T is (Ast);
procedure Print (Ast : in Mal.T) is
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line));
exception
when Reader.Empty_Source =>
null;
when E : Reader.Reader_Error =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep is
begin
Print (Eval (Read));
end Rep;
----------------------------------------------------------------------
begin
Interactive_Loop;
loop
begin
Rep;
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Reader.Reader_Error =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Step1_Read_Print;

122
ada2/step2_eval.adb
View File

@ -1,57 +1,48 @@
with Ada.Containers.Indefinite_Hashed_Maps;
with Ada.Exceptions;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Printer;
with Reader;
with Types.Builtins;
with Readline;
with Types.Lists;
with Types.Mal;
with Types.Maps;
procedure Step2_Eval is
package ASU renames Ada.Strings.Unbounded;
use Types;
package Environments is new Ada.Containers.Indefinite_Hashed_Maps
package Envs is new Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => Builtins.Ptr,
Element_Type => Mal.Builtin_Ptr,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=",
"=" => Builtins."=");
Unknown_Symbol : exception;
"=" => Mal."=");
Unknown_Key : exception;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast : in Mal.T;
Env : in Environments.Map) return Mal.T;
Env : in Envs.Map) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Map) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Map);
procedure Rep (Env : in Envs.Map) with Inline;
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Map, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Map, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Map, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Environments.Map) return Mal.T is
Env : in Envs.Map) return Mal.T
is
First : Mal.T;
begin
-- Ada.Text_IO.New_Line;
@ -64,80 +55,57 @@ procedure Step2_Eval is
return Ast;
when Kind_Symbol =>
declare
S : constant String := Ast.Symbol.To_String;
C : constant Environments.Cursor := Env.Find (S);
S : constant String := Ast.Symbol.To_String;
C : constant Envs.Cursor := Env.Find (S);
begin
if Environments.Has_Element (C) then
return (Kind_Builtin, Environments.Element (C));
if Envs.Has_Element (C) then
return (Kind_Builtin, Envs.Element (C));
else
-- The predefined message does not pass tests.
raise Unknown_Symbol with "'" & S & "' not found";
raise Unknown_Key with "'" & S & "' not found";
end if;
end;
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Eval (Ast.L.Element (1), Env);
First := Eval (Ast.List.Element (1), Env);
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T
is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number,
Args (Args'Last).Ada_Number));
is (Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
procedure Interactive_Loop (Repl : in Environments.Map) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Print (Ast : in Mal.T) is
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Unknown_Symbol =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Map) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
@ -146,12 +114,24 @@ procedure Step2_Eval is
function Product is new Generic_Mal_Operator ("*");
function Division is new Generic_Mal_Operator ("/");
Repl : Environments.Map;
Repl : Envs.Map;
begin
Repl.Insert ("+", Addition 'Unrestricted_Access);
Repl.Insert ("-", Subtraction'Unrestricted_Access);
Repl.Insert ("*", Product 'Unrestricted_Access);
Repl.Insert ("/", Division 'Unrestricted_Access);
Interactive_Loop (Repl);
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Reader.Reader_Error | Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Step2_Eval;

143
ada2/step3_env.adb
View File

@ -1,11 +1,10 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Environments;
with Envs;
with Printer;
with Reader;
with Readline;
with Types.Lists;
with Types.Mal;
with Types.Maps;
@ -13,43 +12,36 @@ with Types.Symbols.Names;
procedure Step3_Env is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
procedure Rep (Env : in Envs.Ptr) with Inline;
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T is
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
First : Mal.T;
begin
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -60,36 +52,38 @@ procedure Step3_Env is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
New_Env : constant Environments.Ptr := Env.Sub;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
-- This curious syntax is useful for later steps.
New_Env : Envs.Ptr := Env.Copy_Pointer;
begin
New_Env.Replace_With_Sub;
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
@ -100,7 +94,7 @@ procedure Step3_Env is
New_Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), New_Env));
end loop;
return Eval (Ast.L.Element (3), New_Env);
return Eval (Ast.List.Element (3), New_Env);
end;
else
-- Equivalent to First := Eval (First, Env), except that
@ -112,57 +106,34 @@ procedure Step3_Env is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T
is (Kind_Number, Ada_Operator (Args (Args'First).Ada_Number,
Args (Args'Last).Ada_Number));
is (Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Print (Ast : in Mal.T) is
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
@ -171,14 +142,28 @@ procedure Step3_Env is
function Product is new Generic_Mal_Operator ("*");
function Division is new Generic_Mal_Operator ("/");
function S (Source : in String) return Symbols.Ptr
renames Symbols.Constructor;
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
begin
Repl.Set (S ("+"), (Kind_Builtin, Addition 'Unrestricted_Access));
Repl.Set (S ("-"), (Kind_Builtin, Subtraction'Unrestricted_Access));
Repl.Set (S ("*"), (Kind_Builtin, Product 'Unrestricted_Access));
Repl.Set (S ("/"), (Kind_Builtin, Division 'Unrestricted_Access));
Interactive_Loop (Repl);
Repl.Set (Symbols.Constructor ("+"),
(Kind_Builtin, Addition 'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("-"),
(Kind_Builtin, Subtraction'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("*"),
(Kind_Builtin, Product 'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("/"),
(Kind_Builtin, Division 'Unrestricted_Access));
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Step3_Env;

189
ada2/step4_if_fn_do.adb
View File

@ -1,12 +1,12 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -15,42 +15,37 @@ with Types.Symbols.Names;
procedure Step4_If_Fn_Do is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T is
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
First : Mal.T;
begin
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -61,75 +56,78 @@ procedure Step4_If_Fn_Do is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
return Eval (Ast.L.Element (Ast.L.Length), Env);
return Eval (Ast.List.Element (Ast.List.Length), Env);
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
return Eval (Ast.L.Element (3), Env);
elsif Ast.L.Length = 3 then
return Eval (Ast.List.Element (3), Env);
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
return Eval (Ast.L.Element (4), Env);
return Eval (Ast.List.Element (4), Env);
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
New_Env : constant Environments.Ptr := Env.Sub;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
-- This curious syntax is useful for later steps.
New_Env : Envs.Ptr := Env.Copy_Pointer;
begin
New_Env.Replace_With_Sub;
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
@ -140,7 +138,7 @@ procedure Step4_If_Fn_Do is
New_Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), New_Env));
end loop;
return Eval (Ast.L.Element (3), New_Env);
return Eval (Ast.List.Element (3), New_Env);
end;
else
-- Equivalent to First := Eval (First, Env), except that
@ -152,74 +150,75 @@ procedure Step4_If_Fn_Do is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
New_Env : constant Environments.Ptr
:= First.Function_Value.Closure.Closure_Sub;
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
First.Function_Value.Set_Binds (New_Env, Args);
return Eval (First.Function_Value.Expression, New_Env);
return First.Fn.Apply (Args);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
Interactive_Loop (Repl);
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Step4_If_Fn_Do;

190
ada2/step5_tco.adb
View File

@ -1,12 +1,12 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -15,48 +15,42 @@ with Types.Symbols.Names;
procedure Step5_Tco is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -67,76 +61,77 @@ procedure Step5_Tco is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -149,7 +144,7 @@ procedure Step5_Tco is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
else
@ -162,74 +157,79 @@ procedure Step5_Tco is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
Interactive_Loop (Repl);
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Step5_Tco;

194
ada2/step6_file.adb
View File

@ -2,12 +2,13 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -18,46 +19,41 @@ procedure Step6_File is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -68,76 +64,77 @@ procedure Step6_File is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -150,7 +147,7 @@ procedure Step6_File is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
else
@ -163,78 +160,71 @@ procedure Step6_File is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
use Ada.Command_Line;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
-- Define ARGV from command line arguments.
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
@ -243,9 +233,23 @@ begin
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
-- Script?
if 0 < Argument_Count then
Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl);
else
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end if;
end Step6_File;

230
ada2/step7_quote.adb
View File

@ -2,12 +2,13 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -18,53 +19,48 @@ procedure Step7_Quote is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -75,76 +71,77 @@ procedure Step7_Quote is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -157,19 +154,19 @@ procedure Step7_Quote is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
return Quasiquote (Ast.List.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
return Ast.List.Element (2);
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
@ -180,70 +177,51 @@ procedure Step7_Quote is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
@ -254,15 +232,15 @@ procedure Step7_Quote is
for I in R'Range loop
R (I) := List.Element (I);
if R (I).Kind in Kind_List | Kind_Vector
and then 0 < R (I).L.Length
and then R (I).L.Element (1).Kind = Kind_Symbol
and then R (I).L.Element (1).Symbol
and then 0 < R (I).List.Length
and then R (I).List.Element (1).Kind = Kind_Symbol
and then R (I).List.Element (1).Symbol
= Symbols.Names.Splice_Unquote
then
if R (I).L.Length /= 2 then
if R (I).List.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 arg";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
R (I) := Eval (R (I).List.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
@ -278,33 +256,47 @@ procedure Step7_Quote is
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
when Kind_List =>
if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
if 0 < Ast.List.Length
and then Ast.List.Element (1).Kind = Kind_Symbol
and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote
then
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
else
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
end if;
when others =>
return Ast;
end case;
end Quasiquote;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
use Ada.Command_Line;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
-- Define ARGV from command line arguments.
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
@ -313,9 +305,23 @@ begin
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
-- Script?
if 0 < Argument_Count then
Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl);
else
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end if;
end Step7_Quote;

256
ada2/step8_macros.adb
View File

@ -2,12 +2,13 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -18,54 +19,49 @@ procedure Step8_Macros is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -76,92 +72,93 @@ procedure Step8_Macros is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "defmacro!: arg 1 must be a symbol";
end if;
declare
F : constant Mal.T := Eval (Ast.L.Element (3), Env);
F : constant Mal.T := Eval (Ast.List.Element (3), Env);
begin
if F.Kind /= Kind_Function then
raise Argument_Error with "defmacro!: expects a function";
end if;
return R : constant Mal.T := F.Function_Value.New_Macro do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -174,26 +171,26 @@ procedure Step8_Macros is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
Ast := Ast.List.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
return Quasiquote (Ast.List.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
return Ast.List.Element (2);
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
@ -204,82 +201,61 @@ procedure Step8_Macros is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
New_Env : constant Environments.Ptr := Env.Sub;
begin
First.Function_Value.Set_Binds (New_Env, Ast.L);
Ast := Eval (First.Function_Value.Expression, New_Env);
end;
Ast := Eval (Ast0 => First.Fn.Ast,
Env0 => Envs.Sub (Outer => Env,
Binds => First.Fn.Params,
Exprs => Ast.List));
if Macroexpanding then
return Ast;
else
goto Restart;
end if;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
@ -290,15 +266,15 @@ procedure Step8_Macros is
for I in R'Range loop
R (I) := List.Element (I);
if R (I).Kind in Kind_List | Kind_Vector
and then 0 < R (I).L.Length
and then R (I).L.Element (1).Kind = Kind_Symbol
and then R (I).L.Element (1).Symbol
and then 0 < R (I).List.Length
and then R (I).List.Element (1).Kind = Kind_Symbol
and then R (I).List.Element (1).Symbol
= Symbols.Names.Splice_Unquote
then
if R (I).L.Length /= 2 then
if R (I).List.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 arg";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
R (I) := Eval (R (I).List.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
@ -314,24 +290,31 @@ procedure Step8_Macros is
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
when Kind_List =>
if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
if 0 < Ast.List.Length
and then Ast.List.Element (1).Kind = Kind_Symbol
and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote
then
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
else
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
end if;
when others =>
return Ast;
end case;
end Quasiquote;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
@ -347,11 +330,18 @@ procedure Step8_Macros is
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
use Ada.Command_Line;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
-- Define ARGV from command line arguments.
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
@ -360,9 +350,23 @@ begin
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
-- Script?
if 0 < Argument_Count then
Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl);
else
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end if;
end Step8_Macros;

279
ada2/step9_try.adb
View File

@ -2,12 +2,13 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -18,54 +19,49 @@ procedure Step9_Try is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -76,92 +72,93 @@ procedure Step9_Try is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "defmacro!: arg 1 must be a symbol";
end if;
declare
F : constant Mal.T := Eval (Ast.L.Element (3), Env);
F : constant Mal.T := Eval (Ast.List.Element (3), Env);
begin
if F.Kind /= Kind_Function then
raise Argument_Error with "defmacro!: expects a function";
end if;
return R : constant Mal.T := F.Function_Value.New_Macro do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -174,37 +171,37 @@ procedure Step9_Try is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
Ast := Ast.List.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
return Quasiquote (Ast.List.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
return Ast.List.Element (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.L.Length = 2 then
Ast := Ast.L.Element (2);
if Ast.List.Length = 2 then
Ast := Ast.List.Element (2);
goto Restart;
elsif Ast.L.Length /= 3 then
elsif Ast.List.Length /= 3 then
raise Argument_Error with "try*: expects 1 or 2 arguments";
elsif Ast.L.Element (3).Kind /= Kind_List then
elsif Ast.List.Element (3).Kind /= Kind_List then
raise Argument_Error with "try*: argument 2 must be a list";
end if;
declare
A3 : constant Lists.Ptr := Ast.L.Element (3).L;
A3 : constant Lists.Ptr := Ast.List.Element (3).List;
begin
if A3.Length /= 3 then
raise Argument_Error with "try*: arg 2 must have 3 elements";
@ -216,10 +213,10 @@ procedure Step9_Try is
raise Argument_Error with "catch*: expects a symbol";
end if;
begin
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
exception
when E : Reader.Empty_Source | Argument_Error
| Reader.Reader_Error | Environments.Unknown_Key =>
| Reader.Reader_Error | Envs.Unknown_Key =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol,
Mal.T'(Kind_String, ASU.To_Unbounded_String
@ -229,7 +226,6 @@ procedure Step9_Try is
when Core.Exception_Throwed =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol, Core.Last_Exception);
Core.Last_Exception := Mal.Nil;
Ast := A3.Element (3);
goto Restart;
-- Other exceptions are unexpected.
@ -245,86 +241,61 @@ procedure Step9_Try is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
New_Env : constant Environments.Ptr := Env.Sub;
begin
First.Function_Value.Set_Binds (New_Env, Ast.L);
Ast := Eval (First.Function_Value.Expression, New_Env);
end;
Ast := Eval (Ast0 => First.Fn.Ast,
Env0 => Envs.Sub (Outer => Env,
Binds => First.Fn.Params,
Exprs => Ast.List));
if Macroexpanding then
return Ast;
else
goto Restart;
end if;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
when Core.Exception_Throwed =>
Ada.Text_IO.Put ("User exception: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception));
Core.Last_Exception := Mal.Nil;
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
@ -335,15 +306,15 @@ procedure Step9_Try is
for I in R'Range loop
R (I) := List.Element (I);
if R (I).Kind in Kind_List | Kind_Vector
and then 0 < R (I).L.Length
and then R (I).L.Element (1).Kind = Kind_Symbol
and then R (I).L.Element (1).Symbol
and then 0 < R (I).List.Length
and then R (I).List.Element (1).Kind = Kind_Symbol
and then R (I).List.Element (1).Symbol
= Symbols.Names.Splice_Unquote
then
if R (I).L.Length /= 2 then
if R (I).List.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 arg";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
R (I) := Eval (R (I).List.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
@ -359,24 +330,31 @@ procedure Step9_Try is
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
when Kind_List =>
if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
if 0 < Ast.List.Length
and then Ast.List.Element (1).Kind = Kind_Symbol
and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote
then
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
else
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
end if;
when others =>
return Ast;
end case;
end Quasiquote;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
@ -392,11 +370,18 @@ procedure Step9_Try is
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
use Ada.Command_Line;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
-- Define ARGV from command line arguments.
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
@ -405,9 +390,27 @@ begin
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
-- Script?
if 0 < Argument_Count then
Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl);
else
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
when Core.Exception_Throwed =>
Ada.Text_IO.Put ("User exception: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str
(Core.Last_Exception));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end if;
end Step9_Try;

289
ada2/stepa_mal.adb
View File

@ -2,12 +2,13 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings;
with Core;
with Environments;
with Envs;
with Eval_Cb;
with Printer;
with Reader;
with Readline;
with Types.Functions;
with Types.Lists;
with Types.Mal;
@ -18,54 +19,49 @@ procedure StepA_Mal is
package ASU renames Ada.Strings.Unbounded;
use Types;
use type Symbols.Ptr;
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Read return Mal.T with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
Env : in Envs.Ptr) return Mal.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
procedure Print (Ast : in Mal.T) with Inline;
function Rep (Source : in String;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_List_Elts is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Environments.Ptr, Eval);
function Eval_List_Elts is new Lists.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
-- Procedural form of Eval.
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Mal.T) is null;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr) with Inline;
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T
Env0 : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
-- Envs.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function
@ -76,92 +72,93 @@ procedure StepA_Mal is
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_List_Elts (Ast.L, Env));
return (Kind_Vector, Eval_List_Elts (Ast.List, Env));
when Kind_List =>
if Ast.L.Length = 0 then
if Ast.List.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
First := Ast.List.Element (1);
-- Special forms
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "def!: arg 1 must be a symbol";
end if;
return R : constant Mal.T := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.List.Element (3), Env) do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.Element (2).Kind /= Kind_Symbol then
elsif Ast.List.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "defmacro!: arg 1 must be a symbol";
end if;
declare
F : constant Mal.T := Eval (Ast.L.Element (3), Env);
F : constant Mal.T := Eval (Ast.List.Element (3), Env);
begin
if F.Kind /= Kind_Function then
raise Argument_Error with "defmacro!: expects a function";
end if;
return R : constant Mal.T := F.Function_Value.New_Macro do
Env.Set (Ast.L.Element (2).Symbol, R);
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.List.Element (2).Symbol, R);
end return;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.Length = 1 then
if Ast.List.Length = 1 then
raise Argument_Error with "do: expects at least 1 argument";
end if;
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
for I in 2 .. Ast.List.Length - 1 loop
Eval_P (Ast.List.Element (I), Env);
end loop;
Ast := Ast.L.Element (Ast.L.Length);
Ast := Ast.List.Element (Ast.List.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "fn*: arg 1 must be a list or vector";
elsif (for some F in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (F).Kind /= Kind_Symbol)
elsif (for some F in 1 .. Ast.List.Element (2).List.Length =>
Ast.List.Element (2).List.Element (F).Kind /= Kind_Symbol)
then
raise Argument_Error with "fn*: arg 2 must contain symbols";
end if;
return Functions.New_Function (Ast.L.Element (2).L,
Ast.L.Element (3), Env.New_Closure);
return Functions.New_Function (Params => Ast.List.Element (2).List,
Ast => Ast.List.Element (3),
Env => Env.New_Closure);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.Length not in 3 .. 4 then
if Ast.List.Length not in 3 .. 4 then
raise Argument_Error with "if: expects 2 or 3 arguments";
end if;
declare
Test : constant Mal.T := Eval (Ast.L.Element (2), Env);
Test : constant Mal.T := Eval (Ast.List.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Ada_Boolean,
when others => True)
then
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
elsif Ast.List.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
Ast := Ast.List.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
if Ast.List.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
elsif Ast.List.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
Bindings : constant Lists.Ptr := Ast.List.Element (2).List;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
@ -174,37 +171,37 @@ procedure StepA_Mal is
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
Ast := Ast.List.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
Ast := Ast.List.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
return Quasiquote (Ast.List.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
if Ast.List.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
return Ast.List.Element (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.L.Length = 2 then
Ast := Ast.L.Element (2);
if Ast.List.Length = 2 then
Ast := Ast.List.Element (2);
goto Restart;
elsif Ast.L.Length /= 3 then
elsif Ast.List.Length /= 3 then
raise Argument_Error with "try*: expects 1 or 2 arguments";
elsif Ast.L.Element (3).Kind /= Kind_List then
elsif Ast.List.Element (3).Kind /= Kind_List then
raise Argument_Error with "try*: argument 2 must be a list";
end if;
declare
A3 : constant Lists.Ptr := Ast.L.Element (3).L;
A3 : constant Lists.Ptr := Ast.List.Element (3).List;
begin
if A3.Length /= 3 then
raise Argument_Error with "try*: arg 2 must have 3 elements";
@ -216,10 +213,10 @@ procedure StepA_Mal is
raise Argument_Error with "catch*: expects a symbol";
end if;
begin
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
exception
when E : Reader.Empty_Source | Argument_Error
| Reader.Reader_Error | Environments.Unknown_Key =>
| Reader.Reader_Error | Envs.Unknown_Key =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol,
Mal.T'(Kind_String, ASU.To_Unbounded_String
@ -229,7 +226,6 @@ procedure StepA_Mal is
when Core.Exception_Throwed =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol, Core.Last_Exception);
Core.Last_Exception := Mal.Nil;
Ast := A3.Element (3);
goto Restart;
-- Other exceptions are unexpected.
@ -245,95 +241,70 @@ procedure StepA_Mal is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Builtin_With_Meta =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
return First.Builtin_With_Meta.Data.all (Args);
return First.Builtin_With_Meta.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
Args : Mal.T_Array (2 .. Ast.List.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
Args (I) := Eval (Ast.List.Element (I), Env);
end loop;
Env.Replace_With_Closure_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
New_Env : constant Environments.Ptr := Env.Sub;
begin
First.Function_Value.Set_Binds (New_Env, Ast.L);
Ast := Eval (First.Function_Value.Expression, New_Env);
end;
Ast := Eval (Ast0 => First.Fn.Ast,
Env0 => Envs.Sub (Outer => Env,
Binds => First.Fn.Params,
Exprs => Ast.List));
if Macroexpanding then
return Ast;
else
goto Restart;
end if;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
raise Argument_Error with "cannot call " & Printer.Img (First);
end case;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr) is
use Interfaces.C, Interfaces.C.Strings;
function Readline (Prompt : in char_array) return chars_ptr
with Import, Convention => C, External_Name => "readline";
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
procedure Eval_P (Ast : in Mal.T;
Env : in Envs.Ptr)
is
Result : constant Mal.T := Eval (Ast, Env);
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Null_Ptr;
declare
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
end if;
Free (C_Line);
Ada.Text_IO.Unbounded_IO.Put_Line (Rep (Line, Repl));
exception
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
when Core.Exception_Throwed =>
Ada.Text_IO.Put ("User exception: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Print (Core.Last_Exception));
Core.Last_Exception := Mal.Nil;
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
pragma Unreferenced (Result);
end Eval_P;
procedure Print (Ast : in Mal.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
Env : in Envs.Ptr) return Mal.T
is
use type Symbols.Ptr;
function Quasiquote_List (List : in Lists.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
@ -344,15 +315,15 @@ procedure StepA_Mal is
for I in R'Range loop
R (I) := List.Element (I);
if R (I).Kind in Kind_List | Kind_Vector
and then 0 < R (I).L.Length
and then R (I).L.Element (1).Kind = Kind_Symbol
and then R (I).L.Element (1).Symbol
and then 0 < R (I).List.Length
and then R (I).List.Element (1).Kind = Kind_Symbol
and then R (I).List.Element (1).Symbol
= Symbols.Names.Splice_Unquote
then
if R (I).L.Length /= 2 then
if R (I).List.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 arg";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
R (I) := Eval (R (I).List.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
@ -368,24 +339,31 @@ procedure StepA_Mal is
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
when Kind_List =>
if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
if 0 < Ast.List.Length
and then Ast.List.Element (1).Kind = Kind_Symbol
and then Ast.List.Element (1).Symbol = Symbols.Names.Unquote
then
return Eval (Ast.L.Element (2), Env);
return Eval (Ast.List.Element (2), Env);
else
return Quasiquote_List (Ast.L);
return Quasiquote_List (Ast.List);
end if;
when others =>
return Ast;
end case;
end Quasiquote;
function Read return Mal.T is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
begin
Print (Eval (Read, Env));
end Rep;
----------------------------------------------------------------------
Startup : constant String := "(do"
Startup : constant String := "(do "
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
@ -406,11 +384,18 @@ procedure StepA_Mal is
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
& "(def! *host-language* ""ada2"")"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
Repl : Envs.Ptr renames Envs.Repl;
use Ada.Command_Line;
begin
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
for Binding of Core.Ns loop
Repl.Set (Binding.Symbol, (Kind_Builtin, Binding.Builtin));
end loop;
-- Native startup procedure.
Eval_P (Reader.Read_Str (Startup), Repl);
-- Define ARGV from command line arguments.
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
@ -419,11 +404,29 @@ begin
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Discard (Eval (Read ("(println (str ""Mal ["" *host-language* ""]""))"),
Repl));
Interactive_Loop (Repl);
-- Script?
if 0 < Argument_Count then
Eval_P (Reader.Read_Str ("(load-file """ & Argument (1) & """)"), Repl);
else
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
Eval_P (Reader.Read_Str
("(println (str ""Mal ["" *host-language* ""]""))"), Repl);
loop
begin
Rep (Repl);
exception
when Readline.End_Of_File =>
exit;
when Reader.Empty_Source =>
null;
when E : Argument_Error | Reader.Reader_Error | Envs.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
when Core.Exception_Throwed =>
Ada.Text_IO.Put ("User exception: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str
(Core.Last_Exception));
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end if;
end StepA_Mal;

48
ada2/types-atoms.adb
View File

@ -1,5 +1,6 @@
with Ada.Unchecked_Deallocation;
with Printer;
with Types.Mal;
package body Types.Atoms is
@ -21,11 +22,10 @@ package body Types.Atoms is
function Atom (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "atom: expects 1 argument"
else
(Kind => Kind_Atom,
Atom => (Ada.Finalization.Controlled with
Ref => new Rec'(Data => Args (Args'First),
Refs => 1))));
else
(Kind_Atom, (Ada.Finalization.Controlled with new Rec'
(Refs => 1,
Data => Args (Args'First)))));
function Deref (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
@ -33,7 +33,10 @@ package body Types.Atoms is
elsif Args (Args'First).Kind /= Kind_Atom then
raise Argument_Error with "deref: expects an atom"
else
(Args (Args'First).Atom.Ref.all.Data));
Args (Args'First).Atom.Ref.all.Data);
function Deref (Item : in Ptr) return Mal.T
is (Item.Ref.all.Data);
procedure Finalize (Object : in out Ptr) is
begin
@ -53,10 +56,37 @@ package body Types.Atoms is
raise Argument_Error with "reset: expects 2 arguments";
elsif Args (Args'First).Kind /= Kind_Atom then
raise Argument_Error with "reset: first argument must be an atom";
else
Args (Args'First).Atom.Ref.all.Data := Args (Args'Last);
return Args (Args'Last);
end if;
Args (Args'First).Atom.Ref.all.Data := Args (Args'Last);
return Args (Args'Last);
end Reset;
function Swap (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length < 2 then
raise Argument_Error with "swap!: expects at least 2 arguments";
elsif Args (Args'First).Kind /= Kind_Atom then
raise Argument_Error with "swap!: first argument must be an atom";
end if;
declare
use type Mal.T_Array;
X : Mal.T renames Args (Args'First).Atom.Ref.all.Data;
F : Mal.T renames Args (Args'First + 1);
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
begin
case F.Kind is
when Kind_Builtin =>
X := F.Builtin.all (A);
when Kind_Builtin_With_Meta =>
X := F.Builtin_With_Meta.Builtin.all (A);
when Kind_Function =>
X := F.Fn.Apply (A);
when others =>
raise Argument_Error
with "swap!: cannot call " & Printer.Img (F);
end case;
return X;
end;
end Swap;
end Types.Atoms;

13
ada2/types-atoms.ads
View File

@ -5,20 +5,15 @@ limited with Types.Mal;
package Types.Atoms is
type Ptr is private;
-- A wrapper for a pointer counting references.
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
-- Built-in functions.
function Atom (Args : in Mal.T_Array) return Mal.T;
function Deref (Args : in Mal.T_Array) return Mal.T;
function Reset (Args : in Mal.T_Array) return Mal.T;
function Swap (Args : in Mal.T_Array) return Mal.T;
-- Helper for print.
function Deref (Item : in Ptr) return Mal.T with Inline;
private

28
ada2/types-builtins.adb
View File

@ -5,24 +5,24 @@ with Types.Mal;
package body Types.Builtins is
type Rec is limited record
Data : Ptr;
Refs : Natural;
Meta : Mal.T;
Builtin : Mal.Builtin_Ptr;
Refs : Natural;
Meta : Mal.T;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr_With_Meta) is
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Data (Item : in Ptr_With_Meta) return Ptr
is (Item.Ref.all.Data);
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr
is (Item.Ref.all.Builtin);
procedure Finalize (Object : in out Ptr_With_Meta) is
procedure Finalize (Object : in out Ptr) is
begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
Object.Ref.all.Refs := Object.Ref.all.Refs - 1;
@ -34,20 +34,20 @@ package body Types.Builtins is
end if;
end Finalize;
function Meta (Item : in Ptr_With_Meta) return Mal.T
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function With_Meta (Data : in Ptr;
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T
is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec'
(Data => Data,
Meta => Metadata,
Refs => 1)));
(Builtin => Builtin,
Meta => Metadata,
Refs => 1)));
function With_Meta (Data : in Ptr_With_Meta;
function With_Meta (Item : in Ptr;
Metadata : in Mal.T) return Mal.T
-- Do not try to reuse the memory. We can hope that this kind of
-- nonsense will be rare.
is (With_Meta (Data.Data, Metadata));
is (With_Meta (Item.Ref.all.Builtin, Metadata));
end Types.Builtins;

39
ada2/types-builtins.ads
View File

@ -4,43 +4,30 @@ limited with Types.Mal;
package Types.Builtins is
type Ptr is access function (Args : in Mal.T_Array) return Mal.T;
-- This access type is efficient and sufficient for most purposes,
-- as counting references is a waste of time for native functions,
-- which are often used as atomic elements. The controlled type
-- below is only useful when one has the silly idea to add
-- metadata to a built-in.
-- Types.Mal.Builtin_Ptr is efficient and sufficient for most
-- purposes, as counting references is a waste of time for native
-- functions. The controlled type below is only useful when one
-- has the silly idea to add metadata to a built-in.
type Ptr_With_Meta is tagged private;
-- A wrapper for a pointer counting references.
type Ptr is tagged private;
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
function With_Meta (Data : in Ptr;
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T with Inline;
function With_Meta (Data : in Ptr_With_Meta;
function With_Meta (Item : in Ptr;
Metadata : in Mal.T) return Mal.T with Inline;
function Meta (Item : in Ptr_With_Meta) return Mal.T with Inline;
function Data (Item : in Ptr_With_Meta) return Ptr with Inline;
function Meta (Item : in Ptr) return Mal.T with Inline;
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline;
private
-- See README for the implementation of reference counting.
type Rec;
type Acc is access Rec;
type Ptr_With_Meta is new Ada.Finalization.Controlled with record
type Ptr is new Ada.Finalization.Controlled with record
Ref : Acc := null;
end record
with Invariant => Ref /= null;
overriding procedure Adjust (Object : in out Ptr_With_Meta) with Inline;
overriding procedure Finalize (Object : in out Ptr_With_Meta) with Inline;
pragma Finalize_Storage_Only (Ptr_With_Meta);
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
pragma Finalize_Storage_Only (Ptr);
end Types.Builtins;

171
ada2/types-functions.adb
View File

@ -1,25 +1,22 @@
with Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Environments;
with Printer;
with Envs;
with Eval_Cb;
with Types.Lists;
with Types.Mal;
with Types.Symbols.Names;
with Types.Symbols;
package body Types.Functions is
subtype AFC is Ada.Finalization.Controlled;
package ASU renames Ada.Strings.Unbounded;
use type Types.Symbols.Ptr;
use type Envs.Closure_Ptr;
type Rec is limited record
Refs : Natural := 1;
Args : Lists.Ptr;
Expr : Mal.T;
Env : Environments.Closure_Ptr := Environments.Null_Closure;
Varargs : Boolean;
Meta : Mal.T := Mal.Nil;
type Rec (Params_Last : Natural) is limited record
Ast : Mal.T;
Refs : Natural := 1;
Env : Envs.Closure_Ptr := Envs.Null_Closure;
Meta : Mal.T := Mal.Nil;
Params : Symbols.Symbol_Array (1 .. Params_Last);
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
@ -31,11 +28,24 @@ package body Types.Functions is
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Closure (Item : in Ptr) return Environments.Closure_Ptr
is (Item.Ref.all.Env);
function Apply (Item : in Ptr;
Args : in Mal.T_Array) return Mal.T is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast,
Env => Envs.Sub (Outer => Item.Ref.all.Env,
Binds => Item.Ref.all.Params,
Exprs => Args));
end Apply;
function Expression (Item : in Ptr) return Mal.T
is (Item.Ref.all.Expr);
function Ast (Item : in Ptr) return Mal.T
is (Item.Ref.all.Ast);
function Env (Item : in Ptr) return Envs.Closure_Ptr is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Item.Ref.all.Env;
end Env;
procedure Finalize (Object : in out Ptr) is
begin
@ -49,25 +59,30 @@ package body Types.Functions is
end if;
end Finalize;
function Formals (Item : in Ptr) return Lists.Ptr
is (Item.Ref.all.Args);
function Params (Item : in Ptr) return Symbols.Symbol_Array
is (Item.Ref.all.Params);
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function Meta (Item : in Ptr) return Mal.T is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Item.Ref.all.Meta;
end Meta;
function New_Function (Formals : in Lists.Ptr;
Expression : in Mal.T;
Environment : in Environments.Closure_Ptr)
function New_Function (Params : in Lists.Ptr;
Ast : in Mal.T;
Env : in Envs.Closure_Ptr)
return Mal.T
is (Kind_Function,
(AFC with new Rec'
(Args => Formals,
Expr => Expression,
Env => Environment,
Varargs => 1 < Formals.Length
and then Formals.Element (Formals.Length - 1).Symbol
= Symbols.Names.Ampersand,
others => <>)));
is
Ref : constant Acc := new Rec'(Params_Last => Params.Length,
Ast => Ast,
Env => Env,
others => <>);
begin
for I in 1 .. Params.Length loop
Ref.all.Params (I) := Params.Element (I).Symbol;
end loop;
return (Kind_Function, (AFC with Ref));
end New_Function;
function New_Macro (Item : in Ptr) return Mal.T is
Old : Rec renames Item.Ref.all;
@ -77,95 +92,37 @@ package body Types.Functions is
if Old.Refs = 1 then
Ref := Item.Ref;
Old.Refs := 2;
Old.Env := Environments.Null_Closure;
-- Finalize the previous closure.
Old.Env := Envs.Null_Closure;
-- Finalize the environment, it will not be used anymore.
Old.Meta := Mal.Nil;
else
Ref := new Rec'(Args => Item.Ref.all.Args,
Expr => Item.Ref.all.Expr,
Varargs => Item.Ref.all.Varargs,
others => <>);
Ref := new Rec'(Params_Last => Old.Params_Last,
Params => Old.Params,
Ast => Old.Ast,
others => <>);
end if;
return (Kind_Macro, (AFC with Ref));
end New_Macro;
procedure Set_Binds (Item : in Ptr;
Env : in Environments.Ptr;
Args : in Mal.T_Array)
is
R : Rec renames Item.Ref.all;
begin
if R.Varargs then
if Args'Length < R.Args.Length - 2 then
raise Argument_Error with "expected "
& ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args)))
& ", got" & Args'Length'Img;
end if;
for I in 1 .. R.Args.Length - 2 loop
Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1));
end loop;
Env.Set (R.Args.Element (R.Args.Length).Symbol,
Lists.List (Args (Args'First + R.Args.Length - 2 .. Args'Last)));
else
if Args'Length /= R.Args.Length then
raise Argument_Error with "expected "
& ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args)))
& ", got" & Args'Length'Img;
end if;
for I in 1 .. R.Args.Length loop
Env.Set (R.Args.Element (I).Symbol, Args (Args'First + I - 1));
end loop;
end if;
end Set_Binds;
procedure Set_Binds (Item : in Ptr;
Env : in Environments.Ptr;
Args : in Lists.Ptr)
is
R : Rec renames Item.Ref.all;
begin
if R.Varargs then
if Args.Length - 1 < R.Args.Length - 2 then
raise Argument_Error with "expected "
& ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args)))
& ", got" & Natural'Image (Args.Length - 1);
end if;
for I in 1 .. R.Args.Length - 2 loop
Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I));
end loop;
Env.Set (R.Args.Element (R.Args.Length).Symbol,
Lists.Slice (Args, R.Args.Length));
else
if Args.Length - 1 /= R.Args.Length then
raise Argument_Error with "expected "
& ASU.To_String (Printer.Pr_Str ((Kind_List, R.Args)))
& ", got" & Natural'Image (Args.Length - 1);
end if;
for I in 1 .. R.Args.Length loop
Env.Set (R.Args.Element (I).Symbol, Args.Element (1 + I));
end loop;
end if;
end Set_Binds;
function With_Meta (Data : in Ptr;
function With_Meta (Item : in Ptr;
Metadata : in Mal.T) return Mal.T
is
Old : Rec renames Data.Ref.all;
Old : Rec renames Item.Ref.all;
Ref : Acc;
begin
pragma Assert (Old.Env /= Envs.Null_Closure);
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Data.Ref;
Ref := Item.Ref;
Old.Refs := 2;
Old.Meta := Metadata;
else
Ref := new Rec'(Args => Data.Ref.all.Args,
Expr => Data.Ref.all.Expr,
Env => Data.Ref.all.Env,
Varargs => Data.Ref.all.Varargs,
Meta => Metadata,
others => <>);
Ref := new Rec'(Params_Last => Old.Params_Last,
Params => Old.Params,
Ast => Old.Ast,
Env => Old.Env,
Meta => Metadata,
others => <>);
end if;
return (Kind_Function, (AFC with Ref));
end With_Meta;

58
ada2/types-functions.ads
View File

@ -1,59 +1,41 @@
private with Ada.Finalization;
limited with Environments;
limited with Envs;
limited with Types.Lists;
limited with Types.Mal;
limited with Types.Symbols;
package Types.Functions is
type Ptr is tagged private;
-- A wrapper for a pointer counting references.
-- A pointer to an user-defined function or macro.
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
function New_Function (Formals : in Lists.Ptr;
Expression : in Mal.T;
Environment : in Environments.Closure_Ptr)
return Mal.T
function New_Function (Params : in Lists.Ptr;
Ast : in Mal.T;
Env : in Envs.Closure_Ptr) return Mal.T
with Inline;
-- Equivalent to a sequence of Set with the formal parameters and
-- Args elements, except for the handling of "&".
-- May raise Argument_Count.
-- For functions.
procedure Set_Binds (Item : in Ptr;
Env : in Environments.Ptr;
Args : in Mal.T_Array);
function New_Macro (Item : in Ptr) return Mal.T with Inline;
-- Set_Binds for macros.
-- It skips the first element of Args.
procedure Set_Binds (Item : in Ptr;
Env : in Environments.Ptr;
Args : in Lists.Ptr);
-- Used when printing, or applying with specific requirements,
-- like allowing tail call optimization or macros.
function Formals (Item : in Ptr) return Lists.Ptr with Inline;
function Expression (Item : in Ptr) return Mal.T with Inline;
function Closure (Item : in Ptr) return Environments.Closure_Ptr
with Inline;
function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline;
function Ast (Item : in Ptr) return Mal.T with Inline;
-- Useful to print.
function Apply (Item : in Ptr;
Args : in Mal.T_Array) return Mal.T with Inline;
-- Fails for macros.
function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline;
-- Fails for macros. Required for TCO, instead of Apply.
function Meta (Item : in Ptr) return Mal.T with Inline;
function With_Meta (Data : in Ptr;
Metadata : in Mal.T)
return Mal.T with Inline;
-- Fails for macros.
function With_Meta (Item : in Ptr;
Metadata : in Mal.T) return Mal.T with Inline;
-- Fails for macros.
private
-- See README for the implementation of reference counting.
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record

170
ada2/types-lists.adb
View File

@ -1,5 +1,6 @@
with Ada.Unchecked_Deallocation;
with Printer;
with Types.Mal;
package body Types.Lists is
@ -45,59 +46,58 @@ package body Types.Lists is
if Arg.Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "concat: expects lists or vectors";
end if;
Sum := Sum + Arg.L.Ref.all.Last;
Sum := Sum + Arg.List.Ref.all.Last;
end loop;
Ref := new Rec (Sum);
for Arg of reverse Args loop
Ref.all.Data (Sum - Arg.L.Ref.all.Last + 1 .. Sum)
:= Arg.L.Ref.all.Data;
Sum := Sum - Arg.L.Ref.all.Last;
Ref.all.Data (Sum - Arg.List.Ref.all.Last + 1 .. Sum)
:= Arg.List.Ref.all.Data;
Sum := Sum - Arg.List.Ref.all.Last;
end loop;
pragma Assert (Sum = 0);
return (Kind_List, (AFC with Ref));
end Concat;
function Conj (Args : in Mal.T_Array) return Mal.T is
Ref : Acc;
begin
if Args'Length = 0 then
raise Argument_Error with "conj: expects at least 1 argument";
end if;
case Args (Args'First).Kind is
when Kind_List =>
Ref := new Rec
(Args'Length - 1 + Args (Args'First).L.Ref.all.Last);
Ref.all.Data (Args'Length .. Ref.all.Last)
:= Args (Args'First).L.Ref.all.Data;
for I in 1 .. Args'Length - 1 loop
Ref.all.Data (I) := Args (Args'Last - I + 1);
end loop;
return (Kind_List, (AFC with Ref));
when Kind_Vector =>
return (Kind_Vector, (AFC with new Rec'
(Last => Args'Length - 1 + Args (Args'First).L.Ref.all.Last,
Data => Args (Args'First).L.Ref.all.Data
& Args (Args'First + 1 .. Args'Last),
others => <>)));
when others =>
raise Argument_Error with "conj: first arg must be list or vector";
end case;
declare
A1 : Mal.T renames Args (Args'First);
Last : constant Natural := Args'Length - 1 + A1.List.Ref.all.Last;
Ref : constant Acc := new Rec (Last);
Data : Mal.T_Array renames Ref.all.Data;
begin
case A1.Kind is
when Kind_List =>
Data (Args'Length .. Ref.all.Last) := A1.List.Ref.all.Data;
for I in 1 .. Args'Length - 1 loop
Data (I) := Args (Args'Last - I + 1);
end loop;
return (Kind_List, (AFC with Ref));
when Kind_Vector =>
Data := A1.List.Ref.all.Data
& Args (Args'First + 1 .. Args'Last);
return (Kind_Vector, (AFC with Ref));
when others =>
raise Argument_Error
with "conj: first argument must be a list or vector";
end case;
end;
end Conj;
function Cons (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 2 then
raise Argument_Error with "cons: expects 2 arguments";
elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "cons: last arg must be a list or vector";
end if;
case Args (Args'Last).Kind is
when Kind_List | Kind_Vector =>
return (Kind_List, (AFC with new Rec'
(Last => 1 + Args (Args'Last).L.Ref.all.Last,
Data => Args (Args'First) & Args (Args'Last).L.Ref.all.Data,
others => <>)));
when others =>
raise Argument_Error with "cons: last arg must be list or vector";
end case;
return (Kind_List, (AFC with new Rec'
(Last => 1 + Args (Args'Last).List.Ref.all.Last,
Data => Args (Args'First) & Args (Args'Last).List.Ref.all.Data,
others => <>)));
end Cons;
function Count (Args : in Mal.T_Array) return Mal.T
@ -108,7 +108,7 @@ package body Types.Lists is
when Kind_Nil =>
(Kind_Number, 0),
when Kind_List | Kind_Vector =>
(Kind_Number, Args (Args'First).L.Ref.all.Last),
(Kind_Number, Args (Args'First).List.Ref.all.Last),
when others =>
raise Argument_Error with "count: expects a list or vector"));
@ -136,10 +136,10 @@ package body Types.Lists is
when Kind_Nil =>
Mal.Nil,
when Kind_List | Kind_Vector =>
(if Args (Args'First).L.Ref.all.Last = 0 then
(if Args (Args'First).List.Ref.all.Last = 0 then
Mal.Nil
else
Args (Args'First).L.Ref.all.Data (1)),
Args (Args'First).List.Ref.all.Data (1)),
when others =>
raise Argument_Error with "first: expects a list or vector"));
@ -173,7 +173,7 @@ package body Types.Lists is
else
(case Args (Args'First).Kind is
when Kind_List | Kind_Vector =>
(Kind_Boolean, Args (Args'First).L.Ref.all.Last = 0),
(Kind_Boolean, Args (Args'First).List.Ref.all.Last = 0),
when others =>
raise Argument_Error with "empty?: expects a list or vector"));
@ -185,6 +185,49 @@ package body Types.Lists is
Last => Args'Length,
others => <>)));
function Map (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 2 then
raise Argument_Error with "map: expects 2 arguments";
elsif Args (Args'Last).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "map: argument 2 must be a list or vector";
end if;
declare
F : Mal.T renames Args (Args'First);
Old : Rec renames Args (Args'Last).List.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Args (Args'Last).List.Ref;
Old.Refs := 2;
Old.Meta := Mal.Nil;
else
Ref := new Rec (Old.Last);
end if;
return R : constant Mal.T := (Kind_List, (AFC with Ref)) do
-- Now we can afford raising an exception.
case F.Kind is
when Kind_Builtin =>
for I in Old.Data'Range loop
Ref.all.Data (I) := F.Builtin.all (Old.Data (I .. I));
end loop;
when Kind_Builtin_With_Meta =>
for I in Old.Data'Range loop
Ref.all.Data (I)
:= F.Builtin_With_Meta.Builtin.all (Old.Data (I .. I));
end loop;
when Kind_Function =>
for I in Old.Data'Range loop
Ref.all.Data (I) := F.Fn.Apply (Old.Data (I .. I));
end loop;
when others =>
raise Argument_Error with "map: cannot call " & Printer.Img (F);
end case;
end return;
end;
end Map;
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
@ -196,34 +239,43 @@ package body Types.Lists is
when Kind_List | Kind_Vector =>
(if Args (Args'First + 1).Kind /= Kind_Number then
raise Argument_Error with "nth: last arg must be a number"
elsif 1 + Args (Args'Last).Ada_Number
in Args (Args'First).L.Ref.all.Data'Range
elsif 1 + Args (Args'Last).Number
in Args (Args'First).List.Ref.all.Data'Range
then
Args (Args'First).L.Ref.all.Data
(1 + Args (Args'Last).Ada_Number)
Args (Args'First).List.Ref.all.Data
(1 + Args (Args'Last).Number)
else
raise Argument_Error with "nth: index out of bounds"),
when others =>
raise Argument_Error with "nth: expects a list or vector"));
function Rest (Args : in Mal.T_Array) return Mal.T
is (Kind_List, (AFC with
(if Args'Length /= 1 then
raise Argument_Error with "rest: expects 1 argument"
else
(case Args (Args'First).Kind is
when Kind_Nil =>
new Rec (0),
when Kind_List | Kind_Vector =>
(if Args (Args'First).L.Ref.all.Last = 0 then
new Rec (0)
else
new Rec'(Last => Args (Args'First).L.Ref.all.Last - 1,
Data => Args (Args'First).L.Ref.all.Data
(2 .. Args (Args'First).L.Ref.all.Last),
others => <>)),
when others =>
raise Argument_Error with "rest: expects a list or vector"))));
function Rest (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 1 then
raise Argument_Error with "rest: expects 1 argument";
end if;
declare
A1 : Mal.T renames Args (Args'First);
Ref : Acc;
begin
case A1.Kind is
when Kind_Nil =>
Ref := new Rec (0);
when Kind_List | Kind_Vector =>
if A1.List.Ref.all.Last = 0 then
Ref := new Rec (0);
else
Ref := new Rec'
(Last => A1.List.Ref.all.Last - 1,
Data => A1.List.Ref.all.Data (2 .. A1.List.Ref.all.Last),
others => <>);
end if;
when others =>
raise Argument_Error with "rest: expects a list or vector";
end case;
return (Kind_List, (AFC with Ref));
end;
end Rest;
function Slice (Item : in Ptr;
Start : in Positive)

10
ada2/types-lists.ads
View File

@ -5,15 +5,6 @@ limited with Types.Mal;
package Types.Lists is
type Ptr is tagged private;
-- A wrapper for a pointer counting references.
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
-- Built-in functions.
function Concat (Args : in Mal.T_Array) return Mal.T;
@ -23,6 +14,7 @@ package Types.Lists is
function First (Args : in Mal.T_Array) return Mal.T;
function Is_Empty (Args : in Mal.T_Array) return Mal.T;
function List (Args : in Mal.T_Array) return Mal.T;
function Map (Args : in Mal.T_Array) return Mal.T;
function Nth (Args : in Mal.T_Array) return Mal.T;
function Rest (Args : in Mal.T_Array) return Mal.T;
function Vector (Args : in Mal.T_Array) return Mal.T;

4
ada2/types-mal.adb
View File

@ -15,14 +15,14 @@ package body Types.Mal is
Right.Kind = Kind_Boolean
and then Left.Ada_Boolean = Right.Ada_Boolean,
when Kind_Number =>
Right.Kind = Kind_Number and then Left.Ada_Number = Right.Ada_Number,
Right.Kind = Kind_Number and then Left.Number = Right.Number,
when Kind_Symbol =>
Right.Kind = Kind_Symbol and then Left.Symbol = Right.Symbol,
-- Here is the part that differs from the predefined equality.
when Kind_Keyword | Kind_String =>
Right.Kind = Left.Kind and then Left.S = Right.S,
when Kind_List | Kind_Vector =>
Right.Kind in Kind_List | Kind_Vector and then Left.L = Right.L,
Right.Kind in Kind_List | Kind_Vector and then Left.List = Right.List,
when Kind_Map =>
Right.Kind = Kind_Map and then Left.Map = Right.Map,
when others =>

14
ada2/types-mal.ads
View File

@ -46,6 +46,10 @@ package Types.Mal is
-- language, and require deep changes (the discriminant can be
-- changed for an in out or access parameter).
type T_Array;
type T;
type Builtin_Ptr is access function (Args : in T_Array) return T;
type T (Kind : Kind_Type := Kind_Nil) is record
case Kind is
when Kind_Nil =>
@ -53,7 +57,7 @@ package Types.Mal is
when Kind_Boolean =>
Ada_Boolean : Boolean;
when Kind_Number =>
Ada_Number : Integer;
Number : Integer;
when Kind_Atom =>
Atom : Atoms.Ptr;
when Kind_Keyword | Kind_String =>
@ -61,15 +65,15 @@ package Types.Mal is
when Kind_Symbol =>
Symbol : Symbols.Ptr;
when Kind_List | Kind_Vector =>
L : Lists.Ptr;
List : Lists.Ptr;
when Kind_Map =>
Map : Maps.Ptr;
when Kind_Builtin =>
Builtin : Builtins.Ptr;
Builtin : Builtin_Ptr;
when Kind_Builtin_With_Meta =>
Builtin_With_Meta : Builtins.Ptr_With_Meta;
Builtin_With_Meta : Builtins.Ptr;
when Kind_Function | Kind_Macro =>
Function_Value : Functions.Ptr;
Fn : Functions.Ptr;
end case;
end record;

11
ada2/types-maps.ads
View File

@ -5,15 +5,6 @@ limited with Types.Mal;
package Types.Maps is
type Ptr is tagged private;
-- A wrapper for a pointer counting references.
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
-- Built-in functions.
function Assoc (Args : in Mal.T_Array) return Mal.T;
@ -52,8 +43,6 @@ package Types.Maps is
private
-- See README for the implementation of reference counting.
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record

22
ada2/types-symbols.adb
View File

@ -87,4 +87,26 @@ package body Types.Symbols is
function To_String (Item : in Ptr) return String
is (Item.Ref.all.Data);
function To_String (Item : in Symbol_Array) return String is
I : Natural := Item'Length + 1;
begin
for S of Item loop
I := I + S.Ref.all.Last;
end loop;
return R : String (1 .. I) do
R (1) := '(';
I := 2;
for S of Item loop
if 2 < I then
R (I) := ' ';
I := I + 1;
end if;
R (I .. I + S.Ref.all.Last - 1) := S.Ref.all.Data;
I := I + S.Ref.all.Last;
end loop;
pragma Assert (I = R'Last);
R (R'Last) := ')';
end return;
end To_String;
end Types.Symbols;

19
ada2/types-symbols.ads
View File

@ -4,18 +4,8 @@ private with Ada.Finalization;
package Types.Symbols with Preelaborate is
type Ptr is tagged private;
-- A wrapper for a pointer counting references.
-- The default value is invalid, new variables must be assigned
-- immediately (a hidden discriminant would prevent this type to
-- become a field inside Types.Mal.T, so we check this with a
-- private invariant a fallback, an invariant in the private part
-- checks that any created object is affected before use.
-- Assignment give another reference to the same storage.
function Constructor (Source : in String) return Ptr with Inline;
-- The only way to assign a valid value.
function To_String (Item : in Ptr) return String with Inline;
@ -25,6 +15,13 @@ package Types.Symbols with Preelaborate is
-- Equality compares the contents.
type Symbol_Array is array (Positive range <>) of Symbols.Ptr;
function To_String (Item : in Symbols.Symbol_Array) return String;
-- Returns something like "(a b)". Convenient for error
-- reporting, but redundant with Printer (where it is more
-- efficient to concatenate directly to an unbounded buffer).
private
-- Only one instance is allocated with a given content. This
@ -43,8 +40,6 @@ private
-- probably because it significantly increases the size of
-- Mal_Type.
-- See README for the implementation of reference counting.
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record