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

Major rewrite, improving style and improving performances.

Browse Source
This commit is contained in:
Nicolas Boulenguez 2019-02-27 22:27:12 +01:00
parent cbbb51b465
commit daffc668e9
47 changed files with 4286 additions and 3617 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

59
ada2/Makefile
View File

@ -1,23 +1,16 @@
# Variables expected on the command line:
OPT := -O2
GNATN := -gnatn
GNATP := -gnatp
ADAFLAGS :=
LDFLAGS :=
DEBUG :=
ifdef DEBUG
# Some warnings require -O1.
OPT := -O1
GNATN :=
GNATP :=
ADAFLAGS := -Wall -Wextra -gnatw.eH.Y -gnatySdouxy -gnatVa -g -gnataEfoqQ \
-fstack-check -pg
LDFLAGS := -pg
else
# -O3 is not recommended as the default by the GCC documentation,
# and -O2 seems to produce slightly better performances.
# See README for a discussion of -gnatp.
ADAFLAGS := -O2 -gnatnp
endif
# Compiler arguments.
CARGS = -gnat2012 $(OPT) $(GNATN) $(GNATP) $(ADAFLAGS)
CARGS = -gnat2012 $(OPT) $(ADAFLAGS)
# Linker arguments.
LARGS = $(LDFLAGS) -lreadline
@ -42,15 +35,18 @@ clean:
# Tell Make how to detect out-of-date executables, and let gnatmake do
# the rest when it must be executed.
TYPES := \
atoms.ads atoms.adb \
environments.ads environments.adb \
lists.ads lists.adb \
maps.ads maps.adb \
names.ads \
printer.ads printer.adb \
reader.ads reader.adb \
types.ads types.adb \
strings.ads strings.adb
environments.ads environments.adb \
printer.ads printer.adb \
reader.ads reader.adb \
types-atoms.ads types-atoms.adb \
types-builtins.ads types-builtins.adb \
types-functions.ads types-functions.adb \
types-lists.ads types-lists.adb \
types-mal.ads types-mal.adb \
types-maps.ads types-maps.adb \
types-symbols-names.ads \
types-symbols.ads types-symbols.adb \
types.ads
CORE := \
core.ads core.adb
@ -61,11 +57,14 @@ $(stepa) : stepA%: stepa%.adb $(TYPES) $(CORE)
$(steps) :
gnatmake $< -o $@ -cargs $(CARGS) -largs $(LARGS)
# Step 8 freezes during the "(or)" test with -gnatp.
step8%: GNATP :=
# The compiler crashes on types.adb with -gnatn.
$(step13) $(step49) $(stepa): types.o
types.o: GNATN :=
types.o: $(TYPES)
gcc -c $(CARGS) types.adb
.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

42
ada2/README Normal file
View File

@ -0,0 +1,42 @@
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
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.
* Lists are implemented as C-style arrays, and most of them can be
allocated on the stack.
Once each component has an explicit interface, various optimizations
have been added: unique allocation of symbols, stack-style allocation
of environments in the current execution path, reuse of existing
memory when the reference count reaches 1...
The eventual performances compete with C-style languages, allthough
all user input is checked (implicit language-defined checks like array
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.
About reference reference counting.
* 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).
Known bugs: the third step of the perf^ada2 target fails during the
final storage deallocation when the executable is built with -gnatp. I
have failed to understand why so far.

52
ada2/atoms.adb
View File

@ -1,52 +0,0 @@
with Ada.Unchecked_Deallocation;
with Types;
package body Atoms is
type Atom_Record is limited record
Data : Types.Mal_Type;
Refs : Positive;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Object => Atom_Record,
Name => Atom_Access);
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
if Object.Ref /= null then
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end if;
end Adjust;
function Alloc (New_Value : in Types.Mal_Type) return Ptr
is (Ada.Finalization.Controlled with
Ref => new Atom_Record'(Data => New_Value,
Refs => 1));
function Deref (Container : in Ptr) return Types.Mal_Type is
(Container.Ref.all.Data);
procedure Finalize (Object : in out Ptr)
is
Refs : Positive;
begin
if Object.Ref /= null then
Refs := Object.Ref.all.Refs;
if 1 < Refs then
Object.Ref.all.Refs := Refs - 1;
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
procedure Set (Container : in Ptr;
New_Value : in Types.Mal_Type) is
begin
Container.Ref.all.Data := New_Value;
end Set;
end Atoms;

36
ada2/atoms.ads
View File

@ -1,36 +0,0 @@
private with Ada.Finalization;
limited with Types;
package Atoms is
-- Equivalent to a Lists.Ptr with zero or one elements.
type Ptr is tagged private;
No_Element : constant Ptr;
function Alloc (New_Value : in Types.Mal_Type) return Ptr
with Inline;
function Deref (Container : in Ptr) return Types.Mal_Type
with Inline, Pre => Container /= No_Element;
procedure Set (Container : in Ptr;
New_Value : in Types.Mal_Type)
with Inline, Pre => Container /= No_Element;
private
type Atom_Record;
type Atom_Access is access Atom_Record;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Atom_Access := null;
end record;
overriding procedure Adjust (Object : in out Ptr)
with Inline;
overriding procedure Finalize (Object : in out Ptr)
with Inline;
-- Predefined equality is fine.
No_Element : constant Ptr := (Ada.Finalization.Controlled with Ref => null);
end Atoms;

927
ada2/core.adb
View File

@ -2,580 +2,477 @@ with Ada.Calendar; use type Ada.Calendar.Time;
with Ada.Characters.Latin_1;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Atoms; use type Atoms.Ptr;
with Lists;
with Maps;
with Names;
with Environments;
with Types.Atoms;
with Types.Builtins;
with Types.Functions;
with Types.Lists;
with Types.Maps;
with Types.Symbols.Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
package body Core is
package ASU renames Ada.Strings.Unbounded;
use Types;
use Types.Lists;
use type Mal.T;
use type Mal.T_Array;
Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock;
Eval : Eval_Callback_Type;
function Apply (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.
function Concatenation_Of_Pr_Str
(Args : in Mal_Type_Array;
Print_Readably : in Boolean := True;
Separator : in String := " ")
return Ada.Strings.Unbounded.Unbounded_String;
function Apply (Args : in Mal_Type_Array) return Mal_Type;
function Assoc (Args : in Mal_Type_Array) return Mal_Type;
function Atom (Args : in Mal_Type_Array) return Mal_Type;
function Concat (Args : in Mal_Type_Array) return Mal_Type;
function Conj (Args : in Mal_Type_Array) return Mal_Type;
function Cons (Args : in Mal_Type_Array) return Mal_Type;
function Contains (Args : in Mal_Type_Array) return Mal_Type;
function Count (Args : in Mal_Type_Array) return Mal_Type;
function Deref (Args : in Mal_Type_Array) return Mal_Type;
function Dissoc (Args : in Mal_Type_Array) return Mal_Type;
function Equals (Args : in Mal_Type_Array) return Mal_Type;
function First (Args : in Mal_Type_Array) return Mal_Type;
function Get (Args : in Mal_Type_Array) return Mal_Type;
function Hash_Map (Args : in Mal_Type_Array) return Mal_Type;
function Is_Empty (Args : in Mal_Type_Array) return Mal_Type;
function Is_False (Args : in Mal_Type_Array) return Mal_Type;
function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type;
function Is_True (Args : in Mal_Type_Array) return Mal_Type;
function Keys (Args : in Mal_Type_Array) return Mal_Type;
function Keyword (Args : in Mal_Type_Array) return Mal_Type;
function List (Args : in Mal_Type_Array) return Mal_Type;
function Map (Args : in Mal_Type_Array) return Mal_Type;
function Meta (Args : in Mal_Type_Array) return Mal_Type;
function Nth (Args : in Mal_Type_Array) return Mal_Type;
function Pr_Str (Args : in Mal_Type_Array) return Mal_Type;
function Println (Args : in Mal_Type_Array) return Mal_Type;
function Prn (Args : in Mal_Type_Array) return Mal_Type;
function Read_String (Args : in Mal_Type_Array) return Mal_Type;
function Readline (Args : in Mal_Type_Array) return Mal_Type;
function Reset (Args : in Mal_Type_Array) return Mal_Type;
function Rest (Args : in Mal_Type_Array) return Mal_Type;
function Seq (Args : in Mal_Type_Array) return Mal_Type;
function Slurp (Args : in Mal_Type_Array) return Mal_Type;
function Str (Args : in Mal_Type_Array) return Mal_Type;
function Swap (Args : in Mal_Type_Array) return Mal_Type;
function Symbol (Args : in Mal_Type_Array) return Mal_Type;
function Throw (Args : in Mal_Type_Array) return Mal_Type;
function Time_Ms (Args : in Mal_Type_Array) return Mal_Type;
function Vals (Args : in Mal_Type_Array) return Mal_Type;
function Vector (Args : in Mal_Type_Array) return Mal_Type;
function With_Meta (Args : in Mal_Type_Array) return Mal_Type;
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));
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type;
function Generic_Mal_Operator (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Number, Atoms.No_Element,
Ada_Operator (Args (Args'First).Integer_Value,
Args (Args'First + 1).Integer_Value));
function Addition is new Generic_Mal_Operator ("+");
function Subtraction is new Generic_Mal_Operator ("-");
function Product is new Generic_Mal_Operator ("*");
function Division is new Generic_Mal_Operator ("/");
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)));
generic
with function Ada_Operator (Left, Right : in Integer) return Boolean;
function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type;
function Generic_Comparison (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Ada_Operator (Args (Args'First).Integer_Value,
Args (Args'First + 1).Integer_Value));
function Greater_Than is new Generic_Comparison (">");
function Greater_Equal is new Generic_Comparison (">=");
function Less_Than is new Generic_Comparison ("<");
function Less_Equal is new Generic_Comparison ("<=");
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)));
generic
Kind : Kind_Type;
function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type;
function Generic_Kind_Test (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element, Args (Args'First).Kind = Kind);
function Is_Atom is new Generic_Kind_Test (Kind_Atom);
function Is_Keyword is new Generic_Kind_Test (Kind_Keyword);
function Is_List is new Generic_Kind_Test (Kind_List);
function Is_Map is new Generic_Kind_Test (Kind_Map);
function Is_Nil is new Generic_Kind_Test (Kind_Nil);
function Is_String is new Generic_Kind_Test (Kind_String);
function Is_Symbol is new Generic_Kind_Test (Kind_Symbol);
function Is_Vector is new Generic_Kind_Test (Kind_Vector);
-- 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 ("/", "/");
function Equals (Args : in Mal.T_Array) return Mal.T;
function Eval (Args : in Mal.T_Array) return Mal.T;
function Greater_Equal is new Generic_Comparison (">=", ">=");
function Greater_Than is new Generic_Comparison (">", ">");
function Is_Atom is new Generic_Kind_Test (Kind_Atom, "atom?");
function Is_False (Args : in Mal.T_Array) return Mal.T;
function Is_Function (Args : in Mal.T_Array) return Mal.T;
function Is_Keyword is new Generic_Kind_Test (Kind_Keyword, "keyword?");
function Is_List is new Generic_Kind_Test (Kind_List, "list?");
function Is_Macro is new Generic_Kind_Test (Kind_Macro, "macro?");
function Is_Map is new Generic_Kind_Test (Kind_Map, "map?");
function Is_Nil is new Generic_Kind_Test (Kind_Nil, "nil?");
function Is_Number is new Generic_Kind_Test (Kind_Number, "number?");
function Is_Sequential (Args : in Mal.T_Array) return Mal.T;
function Is_String is new Generic_Kind_Test (Kind_String, "string?");
function Is_Symbol is new Generic_Kind_Test (Kind_Symbol, "symbol?");
function Is_True (Args : in Mal.T_Array) return Mal.T;
function Is_Vector is new Generic_Kind_Test (Kind_Vector, "vector?");
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;
function Prn (Args : in Mal.T_Array) return Mal.T;
function Product is new Generic_Mal_Operator ("*", "*");
function Read_String (Args : in Mal.T_Array) return Mal.T;
function Readline (Args : in Mal.T_Array) return Mal.T;
function Seq (Args : in Mal.T_Array) return Mal.T;
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;
function With_Meta (Args : in Mal.T_Array) return Mal.T;
----------------------------------------------------------------------
procedure Add_Built_In_Functions
(Repl : in Environments.Ptr;
Eval_Callback : in not null Eval_Callback_Type)
is
function N (N : in Native_Function_Access) return Mal_Type
is (Kind_Native, Atoms.No_Element, N) with Inline;
function Apply (Func : in Mal.T;
Args : in Mal.T_Array;
Name : in String)
return Mal.T is
begin
Eval := Eval_Callback;
Repl.Increase_Capacity (57);
Repl.Set (Names.Apply, N (Apply'Access));
Repl.Set (Names.Assoc, N (Assoc'Access));
Repl.Set (Names.Asterisk, N (Product'Access));
Repl.Set (Names.Atom, N (Atom'Access));
Repl.Set (Names.Concat, N (Concat'Access));
Repl.Set (Names.Conj, N (Conj'Access));
Repl.Set (Names.Cons, N (Cons'Access));
Repl.Set (Names.Contains, N (Contains'Access));
Repl.Set (Names.Count, N (Count'Access));
Repl.Set (Names.Deref, N (Deref'Access));
Repl.Set (Names.Dissoc, N (Dissoc'Access));
Repl.Set (Names.Equals, N (Equals'Access));
Repl.Set (Names.First, N (First'Access));
Repl.Set (Names.Get, N (Get'Access));
Repl.Set (Names.Greater_Equal, N (Greater_Equal'Access));
Repl.Set (Names.Greater_Than, N (Greater_Than'Access));
Repl.Set (Names.Hash_Map, N (Hash_Map'Access));
Repl.Set (Names.Is_Atom, N (Is_Atom'Access));
Repl.Set (Names.Is_Empty, N (Is_Empty'Access));
Repl.Set (Names.Is_False, N (Is_False'Access));
Repl.Set (Names.Is_Keyword, N (Is_Keyword'Access));
Repl.Set (Names.Is_List, N (Is_List'Access));
Repl.Set (Names.Is_Map, N (Is_Map'Access));
Repl.Set (Names.Is_Nil, N (Is_Nil'Access));
Repl.Set (Names.Is_Sequential, N (Is_Sequential'Access));
Repl.Set (Names.Is_String, N (Is_String'Access));
Repl.Set (Names.Is_Symbol, N (Is_Symbol'Access));
Repl.Set (Names.Is_True, N (Is_True'Access));
Repl.Set (Names.Is_Vector, N (Is_Vector'Access));
Repl.Set (Names.Keys, N (Keys'Access));
Repl.Set (Names.Keyword, N (Keyword'Access));
Repl.Set (Names.Less_Equal, N (Less_Equal'Access));
Repl.Set (Names.Less_Than, N (Less_Than'Access));
Repl.Set (Names.List, N (List'Access));
Repl.Set (Names.Map, N (Map'Access));
Repl.Set (Names.Meta, N (Meta'Access));
Repl.Set (Names.Minus, N (Subtraction'Access));
Repl.Set (Names.Nth, N (Nth'Access));
Repl.Set (Names.Plus, N (Addition'Access));
Repl.Set (Names.Pr_Str, N (Pr_Str'Access));
Repl.Set (Names.Println, N (Println'Access));
Repl.Set (Names.Prn, N (Prn'Access));
Repl.Set (Names.Read_String, N (Read_String'Access));
Repl.Set (Names.Readline, N (Readline'Access));
Repl.Set (Names.Reset, N (Reset'Access));
Repl.Set (Names.Rest, N (Rest'Access));
Repl.Set (Names.Seq, N (Seq'Access));
Repl.Set (Names.Slash, N (Division'Access));
Repl.Set (Names.Slurp, N (Slurp'Access));
Repl.Set (Names.Str, N (Str'Access));
Repl.Set (Names.Swap, N (Swap'Access));
Repl.Set (Names.Symbol, N (Symbol'Access));
Repl.Set (Names.Throw, N (Throw'Access));
Repl.Set (Names.Time_Ms, N (Time_Ms'Access));
Repl.Set (Names.Vals, N (Vals'Access));
Repl.Set (Names.Vector, N (Vector'Access));
Repl.Set (Names.With_Meta, N (With_Meta'Access));
end Add_Built_In_Functions;
function Apply (Args : in Mal_Type_Array) return Mal_Type
is
Func : Mal_Type renames Args (Args'First);
List : Lists.Ptr renames Args (Args'Last).L;
Actuals : Mal_Type_Array (1 .. Args'Length - 2 + List.Length);
begin
Actuals (1 .. Args'Length - 2) := Args (Args'First + 1 .. Args'Last - 1);
for I in 1 .. List.Length loop
Actuals (Args'Length - 2 + I) := List.Element (I);
end loop;
if Func.Kind = Kind_Native then
return Func.Native.all (Actuals);
else
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
:= Environments.Alloc (Outer => Func.Environment);
Env : constant Environments.Ptr := Func.Function_Value.Closure.Sub;
begin
Env.Set_Binds (Func.Formals, Actuals);
return Eval.all (Func.Expression.Deref, Env);
Func.Function_Value.Set_Binds (Env, Args);
return Eval_Ref.all (Func.Function_Value.Expression, Env);
end;
end if;
when others =>
raise Argument_Error with Name & ": cannot execute "
& ASU.To_String (Printer.Pr_Str (Func));
end case;
end Apply;
function Assoc (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Map, Atoms.No_Element,
Args (Args'First).Map.Assoc (Args (Args'First + 1 .. Args'Last)));
function Apply (Args : in Mal.T_Array) return Mal.T
is (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
Apply (Args (Args'First),
Args (Args'First + 1 .. Args'Last - 1) & Args (Args'Last).L,
"apply"));
function Atom (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Atom, Atoms.No_Element, Atoms.Alloc (Args (Args'First)));
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 Concat (Args : in Mal_Type_Array) return Mal_Type
is
L : array (Args'Range) of Lists.Ptr;
Sum : Natural := 0;
Result : Lists.Ptr;
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)));
function Is_False (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "false?: expects 1 argument"
else (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean
and then not Args (Args'First).Ada_Boolean));
function Is_Function (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "count: expects 1 argument"
else
(Kind_Boolean, Args (Args'First).Kind in
Kind_Function | Kind_Builtin | Kind_Builtin_With_Meta));
function Is_Sequential (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "sequential?: expects 1 argument"
else
(Kind_Boolean, Args (Args'First).Kind in Kind_List | Kind_Vector));
function Is_True (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "true?: expects 1 argument"
else
(Kind_Boolean, Args (Args'First).Kind = Kind_Boolean
and then Args (Args'First).Ada_Boolean));
function Keyword (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "keyword: expects 1 argument"
elsif Args (Args'First).Kind not in Kind_Keyword | Kind_String then
raise Argument_Error with "keyword: expects a keyword or a string"
else
(Kind_Keyword, Args (Args'First).S));
function Map (Args : in Mal.T_Array) return Mal.T is
begin
for I in Args'Range loop
L (I) := Args (I).L;
Sum := Sum + L (I).Length;
end loop;
Result := Lists.Alloc (Sum);
Sum := 0;
for LI of L loop
for J in 1 .. LI.Length loop
Sum := Sum + 1;
Result.Replace_Element (Sum, LI.Element (J));
end loop;
end loop;
return (Kind_List, Atoms.No_Element, Result);
end Concat;
function Concatenation_Of_Pr_Str
(Args : in Mal_Type_Array;
Print_Readably : in Boolean := True;
Separator : in String := " ")
return Ada.Strings.Unbounded.Unbounded_String
is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin
if 1 <= Args'Length then
Append (Result, Printer.Pr_Str (Args (Args'First), Print_Readably));
for I in Args'First + 1 .. Args'Last loop
Append (Result, Separator);
Append (Result, Printer.Pr_Str (Args (I), Print_Readably));
end loop;
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";
end if;
return Result;
end Concatenation_Of_Pr_Str;
function Conj (Args : in Mal_Type_Array) return Mal_Type
is
List : Lists.Ptr renames Args (Args'First).L;
Result : constant Lists.Ptr
:= Lists.Alloc (List.Length + Args'Length - 1);
begin
if Args (Args'First).Kind = Kind_List then
for I in Args'First + 1 .. Args'Last loop
Result.Replace_Element (Args'Last + 1 - I, Args (I));
end loop;
for I in 1 .. List.Length loop
Result.Replace_Element (Args'Length + I - 1, List.Element (I));
end loop;
return (Kind_List, Atoms.No_Element, Result);
else
for I in 1 .. Args'Length - 1 loop
Result.Replace_Element (List.Length + I, Args (Args'First + I));
end loop;
for I in 1 .. List.Length loop
Result.Replace_Element (I, List.Element (I));
end loop;
return (Kind_Vector, Atoms.No_Element, Result);
end if;
end Conj;
function Cons (Args : in Mal_Type_Array) return Mal_Type
is
List : Lists.Ptr renames Args (Args'First + 1).L;
Result : constant Lists.Ptr := Lists.Alloc (1 + List.Length);
begin
Result.Replace_Element (1, Args (Args'First));
for I in 1 .. List.Length loop
Result.Replace_Element (I + 1, List.Element (I));
end loop;
return (Kind_List, Atoms.No_Element, Result);
end Cons;
function Contains (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Args (Args'First).Map.Contains (Args (Args'First + 1)));
function Count (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Number, Atoms.No_Element,
(if Args (Args'First).Kind = Kind_Nil
then 0
else Args (Args'First).L.Length));
function Deref (Args : in Mal_Type_Array) return Mal_Type
is (Args (Args'First).Reference.Deref);
function Dissoc (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Map, Atoms.No_Element,
Args (Args'First).Map.Dissoc (Args (Args'First + 1 .. Args'Last)));
function Equals (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Args (Args'First) = Args (Args'First + 1));
function First (Args : in Mal_Type_Array) return Mal_Type
is (if Args (Args'First).Kind = Kind_Nil
or else Args (Args'First).L.Length = 0
then (Kind_Nil, Atoms.No_Element)
else Args (Args'First).L.Element (1));
function Get (Args : in Mal_Type_Array) return Mal_Type is
begin
if Args (Args'First).Kind = Kind_Nil then
return (Kind_Nil, Atoms.No_Element);
else
return Args (Args'First).Map.Get (Args (Args'First + 1));
end if;
exception
when Maps.Unknown_Key =>
return (Kind_Nil, Atoms.No_Element);
end Get;
function Hash_Map (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Map, Atoms.No_Element, Maps.Hash_Map (Args));
function Is_Empty (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element, Args (Args'First).L.Length = 0);
function Is_False (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Args (Args'First).Kind = Kind_Boolean
and then not Args (Args'First).Boolean_Value);
function Is_True (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Args (Args'First).Kind = Kind_Boolean
and then Args (Args'First).Boolean_Value);
function Is_Sequential (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Boolean, Atoms.No_Element,
Args (Args'First).Kind in Kind_List | Kind_Vector);
function Keyword (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Keyword, Atoms.No_Element, Args (Args'First).S);
function Keys (Args : in Mal_Type_Array) return Mal_Type
is
M : Maps.Ptr renames Args (Args'First).Map;
Result : constant Mal_Type := (Kind_List, Atoms.No_Element,
Lists.Alloc (M.Length));
I : Natural := 0;
procedure Process (Key, Element : in Mal_Type);
procedure Process (Key, Element : in Mal_Type) is
declare
R : Mal.T_Array (1 .. Args (Args'Last).L.Length);
begin
I := I + 1;
Result.L.Replace_Element (I, Key);
pragma Unreferenced (Element);
end Process;
begin
M.Iterate (Process'Access);
return Result;
end Keys;
function List (Args : in Mal_Type_Array) return Mal_Type
is (Kind_List, Atoms.No_Element, Lists.Alloc (Args));
function Map (Args : in Mal_Type_Array) return Mal_Type
is
Func : Mal_Type renames Args (Args'First);
List : Lists.Ptr renames Args (Args'First + 1).L;
Actuals : Mal_Type_Array (1 .. 1);
Result : constant Lists.Ptr := Lists.Alloc (List.Length);
begin
for I in 1 .. List.Length loop
Actuals (1) := List.Element (I);
if Func.Kind = Kind_Native then
Result.Replace_Element (I, Func.Native.all (Actuals));
else
declare
Env : constant Environments.Ptr
:= Environments.Alloc (Func.Environment);
begin
Env.Set_Binds (Func.Formals, Actuals);
Result.Replace_Element (I, Eval.all (Func.Expression.Deref,
Env));
end;
end if;
end loop;
return (Kind_List, Atoms.No_Element, Result);
for I in R'Range loop
R (I) := Apply (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_Type_Array) return Mal_Type
is (if Args (Args'First).Meta = Atoms.No_Element
then (Kind_Nil, Atoms.No_Element)
else Args (Args'First).Meta.Deref);
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
when Kind_List | Kind_Vector =>
Args (Args'First).L.Meta,
when Kind_Map =>
Args (Args'First).Map.Meta,
when Kind_Function =>
Args (Args'First).Function_Value.Meta,
when Kind_Builtin_With_Meta =>
Args (Args'First).Builtin_With_Meta.Meta,
when others =>
Mal.Nil));
function Nth (Args : in Mal_Type_Array) return Mal_Type
is (Args (Args'First).L.Element (1 + Args (Args'First + 1).Integer_Value));
function Pr_Str (Args : in Mal_Type_Array) return Mal_Type
is (Kind_String, Atoms.No_Element, Strings.Alloc
(Ada.Strings.Unbounded.To_String (Concatenation_Of_Pr_Str (Args))));
function Println (Args : in Mal_Type_Array) return Mal_Type is
function Pr_Str (Args : in Mal.T_Array) return Mal.T is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str
(Args, Print_Readably => False));
return (Kind_Nil, Atoms.No_Element);
end Println;
function Prn (Args : in Mal_Type_Array) return Mal_Type is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Concatenation_Of_Pr_Str (Args));
return (Kind_Nil, Atoms.No_Element);
end Prn;
function Readline (Args : in Mal_Type_Array) return Mal_Type is
begin
Ada.Text_IO.Put (Args (Args'First).S.Deref);
return (Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Text_IO.Get_Line));
exception
when Ada.Text_IO.End_Error =>
return (Kind_Nil, Atoms.No_Element);
end Readline;
function Read_String (Args : in Mal_Type_Array) return Mal_Type
is (Reader.Read_Str (Args (Args'First).S.Deref));
function Reset (Args : in Mal_Type_Array) return Mal_Type is
begin
Args (Args'First).Reference.Set (Args (Args'Last));
return Args (Args'Last);
end Reset;
function Rest (Args : in Mal_Type_Array) return Mal_Type
is
List : Mal_Type renames Args (Args'First);
Len : Natural;
begin
return Result : Mal_Type (Kind_List) do
if List.Kind /= Kind_Nil then
Len := List.L.Length;
if 0 < Len then
Len := Len - 1;
Result.L := Lists.Alloc (Len);
for I in 1 .. Len loop
Result.L.Replace_Element (I, List.L.Element (I + 1));
end loop;
end if;
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;
end if;
end return;
end Rest;
end Pr_Str;
function Seq (Args : in Mal_Type_Array) return Mal_Type is
function Println (Args : in Mal.T_Array) return Mal.T is
use Ada.Text_IO.Unbounded_IO;
begin
if Args (Args'First).Kind = Kind_String then
declare
S : constant String := Args (Args'First).S.Deref;
Result : Lists.Ptr;
begin
if S'Length = 0 then
return (Kind_Nil, Atoms.No_Element);
else
Result := Lists.Alloc (S'Length);
for I in S'Range loop
Result.Replace_Element (I - S'First + 1, Mal_Type'
(Kind_String, Atoms.No_Element,
Strings.Alloc (S (I .. I))));
end loop;
return (Kind_List, Atoms.No_Element, Result);
end if;
end;
elsif Args (Args'First).Kind = Kind_Nil
or else Args (Args'First).L.Length = 0
then
return (Kind_Nil, Atoms.No_Element);
else
return (Kind_List, Atoms.No_Element, Args (Args'First).L);
if 0 < Args'Length then
Put (Printer.Pr_Str (Args (Args'First), Readably => False));
for I in Args'First + 1 .. Args'Last loop
Ada.Text_IO.Put (' ');
Put (Printer.Pr_Str (Args (I), Readably => False));
end loop;
end if;
Ada.Text_IO.New_Line;
return Mal.Nil;
end Println;
function Prn (Args : in Mal.T_Array) return Mal.T is
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
Ada.Text_IO.Put (' ');
Ada.Text_IO.Unbounded_IO.Put (Printer.Pr_Str (Args (I)));
end loop;
end if;
Ada.Text_IO.New_Line;
return Mal.Nil;
end Prn;
function Readline (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 1 then
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";
else
Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S);
return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line);
end if;
exception
when Ada.Text_IO.End_Error =>
return Mal.Nil;
end Readline;
function Read_String (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "read-string: expects 1 argument"
elsif Args (Args'First).Kind /= Kind_String then
raise Argument_Error with "read-string: expects a string"
else
Reader.Read_Str (ASU.To_String (Args (Args'First).S)));
function Seq (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 1 then
raise Argument_Error with "seq: expects 1 argument";
end if;
case Args (Args'First).Kind is
when Kind_Nil =>
return Mal.Nil;
when Kind_String =>
if ASU.Length (Args (Args'First).S) = 0 then
return Mal.Nil;
else
declare
A1 : constant ASU.Unbounded_String := Args (Args'First).S;
R : Mal.T_Array (1 .. ASU.Length (A1));
begin
for I in R'Range loop
R (I) := (Kind_String, ASU.Unbounded_Slice (A1, I, I));
end loop;
return Lists.List (R);
end;
end if;
when Kind_List | Kind_Vector =>
if Args (Args'First).L.Length = 0 then
return Mal.Nil;
else
return (Kind_List, Args (Args'First).L);
end if;
when others =>
raise Argument_Error with "seq: expects a string, list or vector";
end case;
end Seq;
function Slurp (Args : in Mal_Type_Array) return Mal_Type
is
use Ada.Strings.Unbounded;
function Slurp (Args : in Mal.T_Array) return Mal.T is
use Ada.Text_IO;
File : File_Type;
Buffer : Unbounded_String;
Buffer : ASU.Unbounded_String;
begin
Open (File, In_File, Args (Args'First).S.Deref);
while not End_Of_File (File) loop
Append (Buffer, Get_Line (File));
Append (Buffer, Ada.Characters.Latin_1.LF);
end loop;
Close (File);
return (Kind_String, Atoms.No_Element,
Strings.Alloc (To_String (Buffer)));
if Args'Length /= 1 then
raise Argument_Error with "slurp: expects 1 argument";
elsif Args (Args'First).Kind /= Kind_String then
raise Argument_Error with "slurp: expects a string";
else
Open (File, In_File, ASU.To_String (Args (Args'First).S));
while not End_Of_File (File) loop
ASU.Append (Buffer, Get_Line (File));
ASU.Append (Buffer, Ada.Characters.Latin_1.LF);
end loop;
Close (File);
return (Kind_String, Buffer);
end if;
exception
when others =>
Close (File);
raise;
end Slurp;
function Str (Args : in Mal_Type_Array) return Mal_Type
is (Kind_String, Atoms.No_Element, Strings.Alloc
(Ada.Strings.Unbounded.To_String
(Concatenation_Of_Pr_Str (Args,
Print_Readably => False,
Separator => ""))));
function Swap (Args : in Mal_Type_Array) return Mal_Type
is
Atom : Mal_Type renames Args (Args'First);
Func : Mal_Type renames Args (Args'First + 1);
Actuals : Mal_Type_Array (Args'First + 1 .. Args'Last);
Result : Mal_Type;
function Str (Args : in Mal.T_Array) return Mal.T is
begin
Actuals (Actuals'First) := Atom.Reference.Deref;
for I in Actuals'First + 1 .. Args'Last loop
Actuals (I) := Args (I);
end loop;
if Func.Kind = Kind_Native then
Result := Func.Native.all (Actuals);
else
declare
Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Func.Environment);
begin
Env.Set_Binds (Func.Formals, Actuals);
Result := Eval.all (Func.Expression.Deref, Env);
end;
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;
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;
Atom.Reference.Set (Result);
return Result;
declare
X : Mal.T renames Atoms.Deref (Args (Args'First .. Args'First));
FX : Mal.T renames Apply (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_Type_Array) return Mal_Type
is (Kind_Symbol, Atoms.No_Element, Args (Args'First).S);
function Symbol (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "symbol?: expects 1 argument"
else
(Kind_Symbol,
Symbols.Constructor (ASU.To_String (Args (Args'First).S))));
function Throw (Args : in Mal_Type_Array) return Mal_Type is
function Throw (Args : in Mal.T_Array) return Mal.T is
begin
Last_Exception := Args (Args'First);
raise Exception_Throwed;
return (Kind_Nil, Atoms.No_Element); -- GNAT wants a return.
if Args'Length /= 1 then
raise Argument_Error with "throw: expects 1 argument";
else
Last_Exception := Args (Args'First);
raise Exception_Throwed;
return Mal.Nil; -- GNAT wants a return.
end if;
end Throw;
function Time_Ms (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Number, Atoms.No_Element,
Integer (1000.0 * (Ada.Calendar.Clock - Start_Time)));
function Time_Ms (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 0 then
raise Argument_Error with "time: expects no argument"
else
(Kind_Number, Integer (1000.0 * (Ada.Calendar.Clock - Start_Time))));
function Vals (Args : in Mal_Type_Array) return Mal_Type
is
M : Maps.Ptr renames Args (Args'First).Map;
Result : constant Mal_Type := (Kind_List, Atoms.No_Element,
Lists.Alloc (M.Length));
I : Natural := 0;
procedure Process (Key, Element : in Mal_Type);
procedure Process (Key, Element : in Mal_Type) is
begin
I := I + 1;
Result.L.Replace_Element (I, Element);
pragma Unreferenced (Key);
end Process;
begin
M.Iterate (Process'Access);
return Result;
end Vals;
function Vector (Args : in Mal_Type_Array) return Mal_Type
is (Kind_Vector, Atoms.No_Element, Lists.Alloc (Args));
function With_Meta (Args : in Mal_Type_Array) return Mal_Type is
begin
return Result : Mal_Type := Args (Args'First) do
Result.Meta := Atoms.Alloc (Args (Args'First + 1));
end return;
end With_Meta;
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)));
use Symbols;
R : Environments.Ptr renames Environments.Repl;
B : Kind_Type renames Kind_Builtin;
begin
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;

22
ada2/core.ads
View File

@ -1,17 +1,19 @@
with Environments;
with Types; pragma Elaborate_All (Types);
limited with Environments;
with Types.Mal;
package Core is
package Core with Elaborate_Body is
type Eval_Callback_Type is access
function (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
-- Initialization of this package fills Environments.Repl with
-- built-in functions.
procedure Add_Built_In_Functions
(Repl : in Environments.Ptr;
Eval_Callback : in not null Eval_Callback_Type);
Eval_Ref : access function (Ast : in Types.Mal.T;
Env : in Environments.Ptr)
return Types.Mal.T;
-- Set by the main program at startup.
Exception_Throwed : exception;
Last_Exception : Types.Mal_Type;
Last_Exception : Types.Mal.T;
-- When the exception is throwed, Last_Exception is set with the
-- related Data.
end Core;

438
ada2/environments.adb
View File

@ -1,166 +1,348 @@
with Ada.Containers.Hashed_Maps; use type Ada.Containers.Count_Type;
with Ada.Containers.Hashed_Maps;
with Ada.Unchecked_Deallocation;
with Atoms;
with Names;
with Strings; use type Strings.Ptr;
with Types; use type Types.Kind_Type;
package body Environments is
-- There must be a reference level so that functions may keep
-- track of their initial environment, and another one for
-- reallocations.
use Types;
package Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Strings.Ptr,
Element_Type => Types.Mal_Type,
Hash => Strings.Hash,
Equivalent_Keys => Strings."=",
"=" => Types."=");
-- The Eval built-in uses the REPL root environment (index 1),
-- all others parameters only repeat the top index.
type Env_Record is limited record
Data : Maps.Map;
Outer : Env_Access;
Refs : Positive;
end record;
package HM is new Ada.Containers.Hashed_Maps
(Key_Type => Symbols.Ptr,
Element_Type => Mal.T,
Hash => Symbols.Hash,
Equivalent_Keys => Symbols."=",
"=" => Mal."=");
procedure Free is new Ada.Unchecked_Deallocation (Object => Env_Record,
Name => Env_Access);
type Stack_Record
(Outer_On_Stack : Boolean := True) is record
Data : HM.Map := HM.Empty_Map;
Refs : Natural := 1;
-- Only references via the Ptr type.
-- References from the stack or Alias are not counted here.
Alias : Heap_Access := null;
-- Used by the closures and heap records to refer to this stack
-- record, so that if it moves to the heap we only need to
-- update the alias.
case Outer_On_Stack is
when True =>
Outer_Index : Stack_Index := 0;
when False =>
Outer_Ref : Heap_Access := null;
end case;
end record
with Dynamic_Predicate => 0 < Refs
and (Alias = null or else Alias.all.Outer = null)
and (if Outer_On_Stack
then Outer_Index <= Top
else Outer_Ref /= null);
-- It is forbidden to change the discriminant of an access type,
-- so we cannot use a discriminant here.
type Heap_Record is limited record
Refs : Natural := 1;
Data : HM.Map := HM.Empty_Map;
Index : Stack_Index;
Outer : Heap_Access := null;
end record
with Dynamic_Predicate =>
(if Outer = null
then Index in 1 .. Top and Data.Is_Empty
else 0 < Refs);
-- Either an alias for a stack element or an actual environment.
-- There could be one single type, but this would enlarge the
-- stack without simplifying the code, and prevent some more
-- static type checking.
Stack : array (Stack_Index range 1 .. Stack_Index'Last) of Stack_Record;
-- The default value gives a consistent value to Stack (1),
-- compatible with the Repl constant.
procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access);
procedure Unreference (Reference : in out Heap_Access);
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Alloc return Ptr
is (Ada.Finalization.Controlled with
Ref => new Env_Record'(Data => Maps.Empty_Map,
Outer => null,
Refs => 1));
function Alloc (Outer : in Ptr) return Ptr is
begin
Outer.Ref.all.Refs := Outer.Ref.all.Refs + 1;
return (Ada.Finalization.Controlled with
Ref => new Env_Record'(Data => Maps.Empty_Map,
Outer => Outer.Ref,
Refs => 1));
end Alloc;
procedure Finalize (Object : in out Ptr)
is
Ref : Env_Access;
Refs : Positive;
procedure Adjust (Object : in out Closure_Ptr) is
begin
if Object.Ref /= null then
Ref := Object.Ref;
Object.Ref := null;
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end if;
end Adjust;
function Copy_Pointer (Env : in Ptr) return Ptr is
begin
Stack (Env.Index).Refs := Stack (Env.Index).Refs + 1;
return (Ada.Finalization.Limited_Controlled with Env.Index);
end Copy_Pointer;
-- procedure Dump_Stack (Long : Boolean := False) is
-- use Ada.Text_IO;
-- use Ada.Text_IO.Unbounded_IO;
-- begin
-- for I in 1 .. Top loop
-- if Long then
-- Put ("Level");
-- end if;
-- Put (I'Img);
-- if Long then
-- New_Line;
-- Put_Line (" refs=" & Stack (I).Refs'Img);
-- if Stack (I).Alias = null then
-- Put_Line (" no alias");
-- else
-- Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img
-- & " refs");
-- end if;
-- end if;
-- if Long then
-- Put (" outer=");
-- else
-- Put (" (->");
-- end if;
-- if Stack (I).Outer_On_Stack then
-- Put (Stack (I).Outer_Index'Img);
-- elsif Stack (I).Outer_Ref.all.Outer = null then
-- if Long then
-- Put ("alias for ");
-- end if;
-- Put (Stack (I).Outer_Ref.all.Index'Img);
-- else
-- Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img);
-- end if;
-- if Long then
-- New_Line;
-- else
-- Put ("):");
-- end if;
-- for P in Stack (I).Data.Iterate loop
-- if HM.Element (P).Kind /= Kind_Builtin then -- skip built-ins.
-- if Long then
-- Put (" ");
-- else
-- Put (' ');
-- end if;
-- Put (HM.Key (P).To_String);
-- Put (':');
-- Put (Printer.Pr_Str (HM.Element (P)));
-- if Long then
-- New_Line;
-- end if;
-- end if;
-- end loop;
-- if Long then
-- Put (" ... built-ins");
-- else
-- New_Line;
-- end if;
-- end loop;
-- if Long then
-- New_Line;
-- end if;
-- end Dump_Stack;
procedure Finalize (Object : in out Closure_Ptr) is
begin
Unreference (Object.Ref);
end Finalize;
procedure Finalize (Object : in out Ptr) is
begin
if 0 < Object.Index then
if 0 < Stack (Object.Index).Refs then
Stack (Object.Index).Refs := Stack (Object.Index).Refs - 1;
end if;
Object.Index := 0;
-- If Index = Top and there are no more references.
loop
Refs := Ref.all.Refs;
if 1 < Refs then
Ref.all.Refs := Refs - 1;
exit;
end if;
pragma Assert (0 < Top);
declare
Tmp : Env_Access := Ref;
R : Stack_Record renames Stack (Top);
begin
Ref := Ref.all.Outer;
Free (Tmp);
exit when 0 < R.Refs;
if Top = 1 then
R.Data.Clear;
if R.Alias /= null then
pragma Assert (R.Alias.all.Outer = null);
pragma Assert (R.Alias.all.Refs = 0);
Free (R.Alias);
end if;
exit;
elsif R.Alias = null then
R.Data.Clear;
if not R.Outer_On_Stack then
Unreference (R.Outer_Ref);
end if;
elsif R.Alias.all.Refs = 0 then
pragma Assert (R.Alias.all.Outer = null);
Free (R.Alias);
R.Data.Clear;
if not R.Outer_On_Stack then
Unreference (R.Outer_Ref);
end if;
else
-- Detach this environment from the stack.
-- The reference count is already correct.
-- Copy the hashmap contents without reallocation..
R.Alias.all.Data.Move (R.Data);
-- The Index will not be used anymore.
-- We need the parent to have an alias, in case it
-- must be detached later.
if R.Outer_On_Stack then
declare
O : Stack_Record renames Stack (R.Outer_Index);
begin
if O.Alias = null then
O.Alias := new Heap_Record'(Index => R.Outer_Index,
others => <>);
else
O.Alias.all.Refs := O.Alias.all.Refs + 1;
end if;
R.Alias.all.Outer := O.Alias;
end;
else
R.Alias.all.Outer := R.Outer_Ref;
end if;
R.Alias := null;
end if;
end;
exit when Ref = null;
Top := Top - 1;
end loop;
end if;
end Finalize;
function Get (Container : in Ptr;
Key : in Strings.Ptr) return Types.Mal_Type
is
Ref : Env_Access := Container.Ref;
Position : Maps.Cursor;
function Get (Env : in Ptr;
Key : in Symbols.Ptr)
return Mal.T is
Index : Stack_Index := Env.Index;
Ref : Heap_Access;
Definition : HM.Cursor;
begin
loop
Position := Ref.all.Data.Find (Key);
if Maps.Has_Element (Position) then
return Ref.all.Data (Position);
end if;
Ref := Ref.all.Outer;
exit when Ref = null;
end loop;
raise Unknown_Key with "'" & Key.Deref & "' not found";
Main_Loop : loop
Index_Loop : loop
Definition := Stack (Index).Data.Find (Key);
if HM.Has_Element (Definition) then
return HM.Element (Definition);
end if;
exit Index_Loop when not Stack (Index).Outer_On_Stack;
Index := Stack (Index).Outer_Index;
exit Main_Loop when Index = 0;
end loop Index_Loop;
Ref := Stack (Index).Outer_Ref;
Ref_Loop : loop
Definition := Ref.all.Data.Find (Key);
if HM.Has_Element (Definition) then
return HM.Element (Definition);
end if;
exit Ref_Loop when Ref.all.Outer = null;
Ref := Ref.all.Outer;
end loop Ref_Loop;
Index := Ref.all.Index;
end loop Main_Loop;
raise Unknown_Key with "'" & Key.To_String & "' not found";
end Get;
procedure Increase_Capacity (Container : in Ptr;
Capacity : in Natural)
is
New_Capacity : constant Ada.Containers.Count_Type
:= Container.Ref.all.Data.Length
+ Ada.Containers.Count_Type (Capacity);
function New_Closure (Env : in Ptr'Class) return Closure_Ptr is
Alias : Heap_Access renames Stack (Env.Index).Alias;
begin
if Container.Ref.all.Data.Capacity < New_Capacity then
Container.Ref.all.Data.Reserve_Capacity (New_Capacity);
if Alias = null then
Alias := new Heap_Record'(Index => Env.Index, others => <>);
else
Alias.all.Refs := Alias.all.Refs + 1;
end if;
end Increase_Capacity;
return (Ada.Finalization.Controlled with Alias);
end New_Closure;
procedure Replace_With_Subenv (Item : in out Ptr) is
procedure Replace_With_Sub (Env : in out Ptr) is
R : Stack_Record renames Stack (Env.Index);
begin
if 1 < Item.Ref.all.Refs then
Item.Ref := new Env_Record'(Data => Maps.Empty_Map,
Outer => Item.Ref,
Refs => 1);
if Env.Index < Top or 1 < R.Refs
or (R.Alias /= null and then 0 < R.Alias.all.Refs)
then
R.Refs := R.Refs - 1;
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_Index => Env.Index,
others => <>);
Env.Index := Top;
end if;
end Replace_With_Subenv;
-- Else reuse the top stack record, including its map and its
-- unreferenced alias if any.
end Replace_With_Sub;
procedure Set (Container : in Ptr;
Key : in Strings.Ptr;
New_Item : in Types.Mal_Type) is
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class) is
begin
Container.Ref.all.Data.Include (Key, New_Item);
Finalize (Env);
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 => <>);
Env.Index := Top;
end Replace_With_Sub;
procedure Set (Env : in Ptr;
Key : in Symbols.Ptr;
New_Element : in Mal.T) is
begin
Stack (Env.Index).Data.Include (Key, New_Element);
end Set;
procedure Set_Binds (Container : in Ptr;
Formals : in Lists.Ptr;
Actuals : in Types.Mal_Type_Array)
is
-- The assertions should be a precondition, but cannot be
-- expressed with a "limited with" view on Types.
function Sub (Outer : in Closure_Ptr'Class) return Ptr is
begin
if Formals.Length <= 1
or else Formals.Element (Formals.Length - 1).S /= Names.Ampersand
then
pragma Assert (Formals.Length = Actuals'Length);
pragma Assert (for all I in 1 .. Formals.Length =>
Formals.Element (I).Kind = Types.Kind_Symbol
and then Formals.Element (I).S /= Names.Ampersand);
Increase_Capacity (Container, Formals.Length);
for I in 1 .. Formals.Length loop
Container.Ref.all.Data.Include (Formals.Element (I).S,
Actuals (Actuals'First + I - 1));
end loop;
else
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 Sub;
function Sub (Outer : in Ptr) return Ptr is
R : Stack_Record renames Stack (Outer.Index);
begin
R.Refs := R.Refs + 1;
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_Index => Outer.Index,
others => <>);
return (Ada.Finalization.Limited_Controlled with Top);
end Sub;
procedure Unreference (Reference : in out Heap_Access) is
Ref : Heap_Access := Reference;
begin
Reference := null;
loop
exit when Ref = null;
exit when Ref.all.Refs = 0;
Ref.all.Refs := Ref.all.Refs - 1;
exit when 0 < Ref.all.Refs;
exit when Ref.all.Outer = null; -- An alias. Do not free it
-- now, it may be useful for another closure.
declare
Len : constant Natural := Formals.Length - 2;
Tmp : Heap_Access := Ref;
begin
pragma Assert (Len <= Actuals'Length);
pragma Assert (for all I in 1 .. Len =>
Formals.Element (I).Kind = Types.Kind_Symbol
and then Formals.Element (I).S /= Names.Ampersand);
pragma Assert (Formals.Element (Len + 1).Kind = Types.Kind_Symbol);
pragma Assert (Formals.Element (Len + 1).S = Names.Ampersand);
pragma Assert (Formals.Element (Len + 2).Kind = Types.Kind_Symbol);
pragma Assert (Formals.Element (Len + 2).S /= Names.Ampersand);
Increase_Capacity (Container, Len + 1);
for I in 1 .. Len loop
Container.Ref.all.Data.Include
(Formals.Element (I).S, Actuals (Actuals'First + I - 1));
end loop;
Container.Ref.all.Data.Include
(Formals.Element (Formals.Length).S,
(Types.Kind_List, Atoms.No_Element,
Lists.Alloc (Actuals (Actuals'First + Len .. Actuals'Last))));
Ref := Ref.all.Outer;
Free (Tmp);
pragma Unreferenced (Tmp);
end;
end if;
end Set_Binds;
end loop;
end Unreference;
end Environments;

141
ada2/environments.ads
View File

@ -1,54 +1,115 @@
private with Ada.Finalization;
with Lists;
with Strings;
limited with Types;
package Environments is
with Types.Mal;
with Types.Symbols;
type Ptr is tagged private;
-- Any variable must be assigned immediately with one of the two
-- following functions.
function Alloc return Ptr
with Inline;
function Alloc (Outer : in Ptr) return Ptr
with Inline;
-- A hidden invariant ensures this when assertions are enabled.
package Environments with Elaborate_Body is
procedure Increase_Capacity (Container : in Ptr;
Capacity : in Natural)
-- This implementation relies on the fact that the caller only
-- ever references environments in its execution stack.
-- When a function closure references an environment that the
-- execution leaves behind, a dynamically allocated block is used
-- instead.
-- The eval built-in requires REPL (see the implementation of
-- load-file), so we cannot assume that the caller only sees the
-- current environment.
type Ptr (<>) is tagged limited private;
-- This type is controlled in order count the references to a
-- given environment, even during exception propagation.
-- Since Ptr is limited with a hidden discriminant, any variable
-- must immediately be assigned with one of
-- * Repl (in which case a renaming is probably better),
-- * Copy_Pointer,
-- * Sub (either from a Ptr or from a Closure_Ptr).
-- Usual assignment with reference counting is not provided
-- because we want to enforce the use of the more efficient
-- Replace_With_Sub.
Repl : constant Ptr;
-- The top environment.
function Copy_Pointer (Env : in Ptr) return Ptr with Inline;
function Sub (Outer : in Ptr) return Ptr with Inline;
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.
procedure Set (Env : in Ptr;
Key : in Types.Symbols.Ptr;
New_Element : in Types.Mal.T)
with Inline;
procedure Replace_With_Subenv (Item : in out Ptr)
with Inline;
-- Equivalent to Item := Alloc (Outer => Item, Capacity), but
-- faster when Item was the last reference to its environment, as
-- the storage and maps are then reused.
procedure Set (Container : in Ptr;
Key : in Strings.Ptr;
New_Item : in Types.Mal_Type)
with Inline;
procedure Set_Binds (Container : in Ptr;
Formals : in Lists.Ptr;
Actuals : in Types.Mal_Type_Array);
function Get (Container : in Ptr;
Key : in Strings.Ptr) return Types.Mal_Type;
function Get (Env : in Ptr;
Key : in Types.Symbols.Ptr)
return Types.Mal.T;
Unknown_Key : exception;
-- procedure Dump;
-- Function closures.
type Closure_Ptr is tagged private;
Null_Closure : constant Closure_Ptr;
function Sub (Outer : in Closure_Ptr'Class) return Ptr;
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class);
-- Like Env := Sub (Outer => Outer); except that Env is finalized
-- *before* the assignement, so its memory can be reused by the
-- new environment. This is important for tail call optimization.
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.
private
type Env_Record;
type Env_Access is access Env_Record;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Env_Access := null;
-- There must be a reference level so that functions may keep
-- track of their initial environment, and another one for
-- reallocations. The second one is delegated to a predefined Ada
-- container.
-- MAL maps may be tempting, but we do not want to copy the whole
-- map for each addition or removal.
-- Some tests seem to show that a hashmap is three times faster
-- than a vector with (key, value) couples.
-- We allow the null value so that the empty environment in a
-- macro does not trigger an allocation.
-- 300 for normal tests
-- 7_500 for make ada2 && make MAL_IMPL=ada2 test^mal
-- 150_000 for make ada2 && make perf^ada2
type Stack_Index is range 0 .. 150_000;
-- See README for the implementation of reference counting.
type Ptr is new Ada.Finalization.Limited_Controlled with record
Index : Stack_Index := 0;
end record
with Invariant => Ptr.Ref /= null;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr);
-- Predefined equality is fine.
with Invariant => Index in 1 .. Top;
overriding procedure Finalize (Object : in out Ptr) with Inline;
pragma Finalize_Storage_Only (Ptr);
Top : Stack_Index := 1;
Repl : constant Ptr := (Ada.Finalization.Limited_Controlled with 1);
type Heap_Record;
type Heap_Access is access Heap_Record;
type Closure_Ptr is new Ada.Finalization.Controlled with record
Ref : Heap_Access := null;
end record;
overriding procedure Adjust (Object : in out Closure_Ptr) with Inline;
overriding procedure Finalize (Object : in out Closure_Ptr) with Inline;
pragma Finalize_Storage_Only (Closure_Ptr);
Null_Closure : constant Closure_Ptr
:= (Ada.Finalization.Controlled with null);
end Environments;

95
ada2/lists.adb
View File

@ -1,95 +0,0 @@
with Ada.Unchecked_Deallocation;
with Atoms;
with Types;
package body Lists is
type List_Record (Last : Positive) is limited record
Data : Types.Mal_Type_Array (1 .. Last);
Refs : Positive;
end record;
-- The invariant for Ptr is:
-- Ptr.Ref = null or else Ptr.First <= Ptr.Ref.all.Last
-- but we cannot express this in the specification because the limited
-- view on Types forbids to define List_Record there.
procedure Free is new Ada.Unchecked_Deallocation (Object => List_Record,
Name => List_Access);
----------------------------------------------------------------------
function "=" (Left, Right : in Ptr) return Boolean is
(if Left.Ref = null
then Right.Ref = null
else
-- As strange as it may seem, this assertion fails when
-- running "(= [(list)] (list []))".
-- pragma Assert
-- ((Left.Ref.all.Data (1) = Right.Ref.all.Data (1))
-- =
-- (Left.Ref.all.Data (1 .. 1) = Right.Ref.all.Data (1 .. 1)));
-- This may be a compiler bug.
Right.Ref /= null
and then Left.Ref.all.Last = Right.Ref.all.Last
and then (for all I in 1 .. Left.Ref.all.Last =>
Types."=" (Left.Ref.all.Data (I),
Right.Ref.all.Data (I))));
procedure Adjust (Object : in out Ptr) is
begin
if Object.Ref /= null then
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end if;
end Adjust;
function Element (Container : in Ptr;
Index : in Positive) return Types.Mal_Type is
(Container.Ref.all.Data (Index));
procedure Finalize (Object : in out Ptr)
is
Refs : Positive;
begin
-- Ensure that we can be called twice in a row (7.6.1(24)).
if Object.Ref /= null then
Refs := Object.Ref.all.Refs;
if 1 < Refs then
Object.Ref.all.Refs := Refs - 1;
Object.Ref := null;
else
-- pragma Assert (Ptr (Object.Ref.all.Id) = Object.Ref);
-- Ptr (Object.Ref.all.Id) := null;
Free (Object.Ref);
end if;
end if;
end Finalize;
function Length (Source : in Ptr) return Natural is
(if Source.Ref = null then 0 else Source.Ref.all.Last);
function Alloc (Source : in Types.Mal_Type_Array) return Ptr is
(if Source'Length = 0
then Empty_List
else (Ada.Finalization.Controlled with
Ref => new List_Record'(Data => Source,
Last => Source'Length,
Refs => 1)));
function Alloc (Length : in Natural) return Ptr is
(if Length = 0
then Empty_List
else (Ada.Finalization.Controlled with
Ref => new List_Record'
(Data => (1 .. Length => (Types.Kind_Nil, Atoms.No_Element)),
Last => Length,
Refs => 1)));
procedure Replace_Element (Source : in Ptr;
Index : in Positive;
New_Value : in Types.Mal_Type) is
begin
pragma Assert (Source.Ref.all.Refs = 1);
Source.Ref.all.Data (Index) := New_Value;
end Replace_Element;
end Lists;

47
ada2/lists.ads
View File

@ -1,47 +0,0 @@
private with Ada.Finalization;
limited with Types;
package Lists is
-- A pointer to an array of Mal_Type elements. It differs from
-- Ada.Containers.Vectors because assignment give another pointer
-- to the same storage and does not copy contents.
type Ptr is tagged private;
Empty_List : constant Ptr; -- The default value.
function Length (Source : in Ptr) return Natural
with Inline;
function Element (Container : in Ptr;
Index : in Positive) return Types.Mal_Type
with Inline, Pre => Index <= Container.Length;
function Alloc (Length : in Natural) return Ptr
with Inline;
-- All elements are Nil, the default value for Mal_Type.
function Alloc (Source : in Types.Mal_Type_Array) return Ptr
with Inline;
procedure Replace_Element (Source : in Ptr;
Index : in Positive;
New_Value : in Types.Mal_Type)
with Inline, Pre => Index <= Source.Length;
-- An assertion checks that Source is the only reference to its
-- storage.
private
type List_Record;
type List_Access is access List_Record;
type Ptr is new Ada.Finalization.Controlled with record
Ref : List_Access := null;
end record;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
overriding function "=" (Left, Right : in Ptr) return Boolean;
Empty_List : constant Ptr := (Ada.Finalization.Controlled with Ref => null);
end Lists;

160
ada2/maps.adb
View File

@ -1,160 +0,0 @@
with Ada.Containers.Hashed_Maps;
with Ada.Unchecked_Deallocation;
with Strings;
with Types;
package body Maps is
function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type
with Inline, Pre => Item.Kind in Types.Kind_String | Types.Kind_Keyword;
package Hashed_Maps is new Ada.Containers.Hashed_Maps
(Key_Type => Types.Mal_Type,
Element_Type => Types.Mal_Type,
Hash => Hash,
Equivalent_Keys => Types."=",
"=" => Types."=");
type Map_Record is limited record
Data : Hashed_Maps.Map;
Refs : Positive;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Object => Map_Record,
Name => Map_Access);
use type Ada.Containers.Count_Type;
----------------------------------------------------------------------
function "=" (Left, Right : in Ptr) return Boolean is
(Hashed_Maps."=" (Left.Ref.all.Data, Right.Ref.all.Data));
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Assoc (Container : in Ptr;
Pairs : in Types.Mal_Type_Array) return Ptr
is
pragma Assert (Pairs'Length mod 2 = 0);
Pair_Count : constant Ada.Containers.Count_Type
:= Ada.Containers.Count_Type (Pairs'Length) / 2;
Result : Ptr;
begin
Result.Ref.all.Data.Reserve_Capacity (Pair_Count
+ Container.Ref.all.Data.Length);
Result.Ref.all.Data.Assign (Container.Ref.all.Data);
for I in 0 .. Pairs'Length / 2 - 1 loop
pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String
| Types.Kind_Keyword);
Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I),
Pairs (Pairs'First + 2 * I + 1));
end loop;
return Result;
end Assoc;
function Contains (Container : in Ptr;
Key : in Types.Mal_Type) return Boolean is
(Container.Ref.all.Data.Contains (Key));
function Dissoc (Source : in Ptr;
Keys : in Types.Mal_Type_Array) return Ptr
is
Result : Ptr;
begin
Result.Ref.all.Data.Assign (Source.Ref.all.Data);
for I in Keys'Range loop
pragma Assert (Keys (I).Kind in Types.Kind_String
| Types.Kind_Keyword);
Result.Ref.all.Data.Exclude (Keys (I));
end loop;
return Result;
end Dissoc;
procedure Finalize (Object : in out Ptr)
is
Refs : Positive;
begin
-- Finalize may be called twice.
if Object.Ref /= null then
Refs := Object.Ref.all.Refs;
if 1 < Refs then
Object.Ref.all.Refs := Refs - 1;
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
procedure Iterate
(Container : in Ptr;
Process : not null access procedure (Key : in Types.Mal_Type;
Element : in Types.Mal_Type)) is
begin
for Position in Container.Ref.all.Data.Iterate loop
Process.all (Hashed_Maps.Key (Position),
Hashed_Maps.Element (Position));
end loop;
end Iterate;
function Get (Container : in Ptr;
Key : in Types.Mal_Type) return Types.Mal_Type
is
Position : Hashed_Maps.Cursor;
begin
Position := Container.Ref.all.Data.Find (Key);
if Hashed_Maps.Has_Element (Position) then
return Hashed_Maps.Element (Position);
end if;
raise Unknown_Key with "'" & Key.S.Deref & "' not found";
end Get;
function Hash (Item : in Types.Mal_Type) return Ada.Containers.Hash_Type is
(Item.S.Hash);
function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr
is
pragma Assert (Pairs'Length mod 2 = 0);
Pair_Count : constant Ada.Containers.Count_Type
:= Ada.Containers.Count_Type (Pairs'Length) / 2;
Result : Ptr;
begin
Result.Ref.all.Data.Reserve_Capacity (Pair_Count);
for I in 0 .. Pairs'Length / 2 - 1 loop
pragma Assert (Pairs (Pairs'First + 2 * I).Kind in Types.Kind_String
| Types.Kind_Keyword);
Result.Ref.all.Data.Include (Pairs (Pairs'First + 2 * I),
Pairs (Pairs'First + 2 * I + 1));
end loop;
return Result;
end Hash_Map;
procedure Initialize (Object : in out Ptr) is
begin
Object.Ref := new Map_Record'(Data => Hashed_Maps.Empty_Map,
Refs => 1);
end Initialize;
function Length (Container : in Ptr) return Natural
is (Natural (Container.Ref.all.Data.Length));
function Map (Container : in Ptr;
F : not null access function (X : in Types.Mal_Type)
return Types.Mal_Type)
return Ptr
is
Result : Ptr;
begin
Result.Ref.all.Data.Assign (Container.Ref.all.Data);
-- Ensure the invariants before calling F, in case it raises exceptions.
for Position in Result.Ref.all.Data.Iterate loop
Result.Ref.all.Data.Replace_Element
(Position, F.all (Hashed_Maps.Element (Position)));
end loop;
return Result;
end Map;
end Maps;

59
ada2/maps.ads
View File

@ -1,59 +0,0 @@
private with Ada.Finalization;
with Lists;
limited with Types;
package Maps is
-- A pointer to an Ada.Containers.Hashed_Maps.Map of
-- Types.Mal_Type. Keys must be Strings or Keywords. We can
-- probably not state this with a limited with, so this will
-- become an assertion.
type Ptr is tagged private;
-- The default value is empty.
function Length (Container : in Ptr) return Natural
with Inline;
function Hash_Map (Pairs : in Types.Mal_Type_Array) return Ptr;
function Assoc (Container : in Ptr;
Pairs : in Types.Mal_Type_Array) return Ptr;
function Dissoc (Source : in Ptr;
Keys : in Types.Mal_Type_Array) return Ptr;
function Map (Container : in Ptr;
F : not null access function (X : in Types.Mal_Type)
return Types.Mal_Type)
return Ptr;
procedure Iterate
(Container : in Ptr;
Process : not null access procedure (Key : in Types.Mal_Type;
Element : in Types.Mal_Type))
with Inline;
function Contains (Container : in Ptr;
Key : in Types.Mal_Type) return Boolean
with Inline;
function Get (Container : in Ptr;
Key : in Types.Mal_Type) return Types.Mal_Type
with Inline;
Unknown_Key : exception;
private
type Map_Record;
type Map_Access is access Map_Record;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Map_Access := null;
end record
with Invariant => Ptr.Ref /= null;
overriding procedure Initialize (Object : in out Ptr) with Inline;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
overriding function "=" (Left, Right : in Ptr) return Boolean with Inline;
end Maps;

87
ada2/names.ads
View File

@ -1,87 +0,0 @@
with Strings; use Strings;
package Names is
-- Symbols known at compile time are allocated at program
-- start, in order to avoid repeated allocations and
-- deallocations during each Read and /Eval/Print cycle. The
-- reference is kept so each usage does not trigger a search in
-- the global hash map.
Ada2 : constant Ptr := Alloc ("ada2");
Ampersand : constant Ptr := Alloc ("&");
Apply : constant Ptr := Alloc ("apply");
Argv : constant Ptr := Alloc ("*ARGV*");
Assoc : constant Ptr := Alloc ("assoc");
Asterisk : constant Ptr := Alloc ("*");
Atom : constant Ptr := Alloc ("atom");
Catch : constant Ptr := Alloc ("catch*");
Concat : constant Ptr := Alloc ("concat");
Conj : constant Ptr := Alloc ("conj");
Cons : constant Ptr := Alloc ("cons");
Contains : constant Ptr := Alloc ("contains?");
Count : constant Ptr := Alloc ("count");
Def : constant Ptr := Alloc ("def!");
Defmacro : constant Ptr := Alloc ("defmacro!");
Deref : constant Ptr := Alloc ("deref");
Dissoc : constant Ptr := Alloc ("dissoc");
Equals : constant Ptr := Alloc ("=");
Eval : constant Ptr := Alloc ("eval");
First : constant Ptr := Alloc ("first");
Fn : constant Ptr := Alloc ("fn*");
Get : constant Ptr := Alloc ("get");
Greater_Equal : constant Ptr := Alloc (">=");
Greater_Than : constant Ptr := Alloc (">");
Hash_Map : constant Ptr := Alloc ("hash-map");
Host_Language : constant Ptr := Alloc ("*host-language*");
Is_Atom : constant Ptr := Alloc ("atom?");
Is_Empty : constant Ptr := Alloc ("empty?");
Is_False : constant Ptr := Alloc ("false?");
Is_Keyword : constant Ptr := Alloc ("keyword?");
Is_List : constant Ptr := Alloc ("list?");
Is_Map : constant Ptr := Alloc ("map?");
Is_Nil : constant Ptr := Alloc ("nil?");
Is_Sequential : constant Ptr := Alloc ("sequential?");
Is_String : constant Ptr := Alloc ("string?");
Is_Symbol : constant Ptr := Alloc ("symbol?");
Is_True : constant Ptr := Alloc ("true?");
Is_Vector : constant Ptr := Alloc ("vector?");
Keys : constant Ptr := Alloc ("keys");
Keyword : constant Ptr := Alloc ("keyword");
Less_Equal : constant Ptr := Alloc ("<=");
Less_Than : constant Ptr := Alloc ("<");
Let : constant Ptr := Alloc ("let*");
List : constant Ptr := Alloc ("list");
Macroexpand : constant Ptr := Alloc ("macroexpand");
Mal_Do : constant Ptr := Alloc ("do");
Mal_If : constant Ptr := Alloc ("if");
Map : constant Ptr := Alloc ("map");
Meta : constant Ptr := Alloc ("meta");
Minus : constant Ptr := Alloc ("-");
Nth : constant Ptr := Alloc ("nth");
Plus : constant Ptr := Alloc ("+");
Pr_Str : constant Ptr := Alloc ("pr-str");
Println : constant Ptr := Alloc ("println");
Prn : constant Ptr := Alloc ("prn");
Quasiquote : constant Ptr := Alloc ("quasiquote");
Quote : constant Ptr := Alloc ("quote");
Read_String : constant Ptr := Alloc ("read-string");
Readline : constant Ptr := Alloc ("readline");
Reset : constant Ptr := Alloc ("reset!");
Rest : constant Ptr := Alloc ("rest");
Seq : constant Ptr := Alloc ("seq");
Slash : constant Ptr := Alloc ("/");
Slurp : constant Ptr := Alloc ("slurp");
Splice_Unquote : constant Ptr := Alloc ("splice-unquote");
Str : constant Ptr := Alloc ("str");
Swap : constant Ptr := Alloc ("swap!");
Symbol : constant Ptr := Alloc ("symbol");
Throw : constant Ptr := Alloc ("throw");
Time_Ms : constant Ptr := Alloc ("time-ms");
Try : constant Ptr := Alloc ("try*");
Unquote : constant Ptr := Alloc ("unquote");
Vals : constant Ptr := Alloc ("vals");
Vector : constant Ptr := Alloc ("vector");
With_Meta : constant Ptr := Alloc ("with-meta");
end Names;

171
ada2/printer.adb
View File

@ -1,55 +1,48 @@
with Ada.Characters.Latin_1;
with Atoms;
with Lists;
with Maps;
with Strings;
with Types.Atoms;
with Types.Functions;
with Types.Lists;
with Types.Maps;
package body Printer is
use Ada.Strings.Unbounded;
use Types;
procedure Print_Form (Buffer : in out Unbounded_String;
Ast : in Mal_Type;
Print_Readably : in Boolean);
procedure Print_List (Buffer : in out Unbounded_String;
List : in Lists.Ptr;
Print_Readably : in Boolean)
with Inline;
procedure Print_Function (Buffer : in out Unbounded_String;
Formals : in Lists.Ptr;
Expression : in Atoms.Ptr;
Print_Readably : in Boolean)
with Inline;
procedure Print_Map (Buffer : in out Unbounded_String;
Map : in Maps.Ptr;
Print_Readably : in Boolean)
with Inline;
procedure Print_Form (Buffer : in out Unbounded_String;
Ast : in Mal.T;
Readably : in Boolean);
procedure Print_List (Buffer : in out Unbounded_String;
List : in Lists.Ptr;
Readably : in Boolean) with Inline;
procedure Print_Function (Buffer : in out Unbounded_String;
Fn : in Functions.Ptr;
Readably : in Boolean) with Inline;
procedure Print_Map (Buffer : in out Unbounded_String;
Map : in Maps.Ptr;
Readably : in Boolean) with Inline;
----------------------------------------------------------------------
procedure Print_Form (Buffer : in out Unbounded_String;
Ast : in Mal_Type;
Print_Readably : in Boolean) is
procedure Print_Form (Buffer : in out Unbounded_String;
Ast : in Mal.T;
Readably : in Boolean) is
begin
case Ast.Kind is
when Kind_Nil =>
Append (Buffer, "nil");
when Kind_Boolean =>
if Ast.Boolean_Value then
if Ast.Ada_Boolean then
Append (Buffer, "true");
else
Append (Buffer, "false");
end if;
when Kind_Symbol =>
Append (Buffer, Ast.S.Deref);
Append (Buffer, Ast.Symbol.To_String);
when Kind_Number =>
declare
Img : constant String := Integer'Image (Ast.Integer_Value);
Img : constant String := Ast.Ada_Number'Img;
F : Positive := Img'First;
begin
if Img (F) = ' ' then
@ -57,121 +50,113 @@ package body Printer is
end if;
Append (Buffer, Img (F .. Img'Last));
end;
when Kind_Keyword =>
Append (Buffer, ':');
Append (Buffer, Ast.S.Deref);
Append (Buffer, Ast.S);
when Kind_String =>
if Print_Readably then
if Readably then
Append (Buffer, '"');
for C of Ast.S.Deref loop
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;
declare
C : Character;
begin
for I in 1 .. Length (Ast.S) loop
C := Element (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;
end;
Append (Buffer, '"');
else
Append (Buffer, Ast.S.Deref);
Append (Buffer, Ast.S);
end if;
when Kind_List =>
Append (Buffer, '(');
Print_List (Buffer, Ast.L, Print_Readably);
Print_List (Buffer, Ast.L, Readably);
Append (Buffer, ')');
when Kind_Vector =>
Append (Buffer, '[');
Print_List (Buffer, Ast.L, Print_Readably);
Print_List (Buffer, Ast.L, Readably);
Append (Buffer, ']');
when Kind_Map =>
Print_Map (Buffer, Ast.Map, Print_Readably);
when Kind_Native =>
Print_Map (Buffer, Ast.Map, Readably);
when Kind_Builtin | Kind_Builtin_With_Meta =>
Append (Buffer, "#<built-in>");
when Kind_Function =>
Append (Buffer, "#<function ");
Print_Function (Buffer, Ast.Formals, Ast.Expression,
Print_Readably);
Print_Function (Buffer, Ast.Function_Value, Readably);
Append (Buffer, '>');
when Kind_Macro =>
Append (Buffer, "#<macro ");
Print_Function (Buffer, Ast.Mac_Formals, Ast.Mac_Expression,
Print_Readably);
Print_Function (Buffer, Ast.Function_Value, Readably);
Append (Buffer, '>');
when Kind_Atom =>
Append (Buffer, "(atom ");
Print_Form (Buffer, Ast.Reference.Deref, Print_Readably);
Print_Form (Buffer, Atoms.Deref (Mal.T_Array'(1 => Ast)),
Readably);
Append (Buffer, ')');
end case;
end Print_Form;
procedure Print_Function (Buffer : in out Unbounded_String;
Formals : in Lists.Ptr;
Expression : in Atoms.Ptr;
Print_Readably : in Boolean) is
procedure Print_Function (Buffer : in out Unbounded_String;
Fn : in Functions.Ptr;
Readably : in Boolean) is
begin
if 0 < Formals.Length then
Print_List (Buffer, Formals, Print_Readably);
Append (Buffer, " -> ");
Print_Form (Buffer, Expression.Deref, Print_Readably);
end if;
Print_List (Buffer, Fn.Formals, Readably);
Append (Buffer, " -> ");
Print_Form (Buffer, Fn.Expression, Readably);
end Print_Function;
procedure Print_List (Buffer : in out Unbounded_String;
List : in Lists.Ptr;
Print_Readably : in Boolean) is
procedure Print_List (Buffer : in out Unbounded_String;
List : in Lists.Ptr;
Readably : in Boolean) is
begin
if 1 <= List.Length then
Print_Form (Buffer, List.Element (1), Print_Readably);
if 0 < List.Length then
Print_Form (Buffer, List.Element (1), Readably);
for I in 2 .. List.Length loop
Append (Buffer, ' ');
Print_Form (Buffer, List.Element (I), Print_Readably);
Print_Form (Buffer, List.Element (I), Readably);
end loop;
end if;
end Print_List;
procedure Print_Map (Buffer : in out Unbounded_String;
Map : in Maps.Ptr;
Print_Readably : in Boolean)
is
procedure Print_Map (Buffer : in out Unbounded_String;
Map : in Maps.Ptr;
Readably : in Boolean) is
Is_First : Boolean := True;
procedure Process (Key : in Mal_Type;
Element : in Mal_Type);
procedure Process (Key : in Mal_Type;
Element : in Mal_Type) is
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 (Buffer, Key, Print_Readably);
Print_Form (Buffer, Key, Readably);
Append (Buffer, ' ');
Print_Form (Buffer, Element, Print_Readably);
Print_Form (Buffer, Element, Readably);
end Process;
begin
Append (Buffer, '{');
Map.Iterate (Process'Access);
Iterate (Map);
Append (Buffer, '}');
end Print_Map;
function Pr_Str (Ast : in Mal_Type;
Print_Readably : in Boolean := True)
return Unbounded_String
is
Result : Unbounded_String;
function Pr_Str (Ast : in Mal.T;
Readably : in Boolean := True) return Unbounded_String is
begin
Print_Form (Result, Ast, Print_Readably);
return Result;
return Buffer : Unbounded_String do
Print_Form (Buffer, Ast, Readably);
end return;
end Pr_Str;
end Printer;

9
ada2/printer.ads
View File

@ -1,12 +1,11 @@
with Ada.Strings.Unbounded;
with Types;
package Printer is
with Types.Mal;
pragma Elaborate_Body;
package Printer with Elaborate_Body is
function Pr_Str (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
function Pr_Str (Ast : in Types.Mal.T;
Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String;
end Printer;

140
ada2/reader.adb
View File

@ -1,18 +1,19 @@
with Ada.Characters.Latin_1;
with Atoms;
with Lists;
with Maps;
with Names;
with Strings;
with Ada.Strings.Unbounded;
with Types.Lists;
with Types.Maps;
with Types.Symbols.Names;
package body Reader is
function Read_Str (Source : in String) return Types.Mal_Type
is
use Types;
function Read_Str (Source : in String) return Mal.T is
First : Positive;
Last : Natural := Source'First - 1;
function Read_Form return Types.Mal_Type;
function Read_Form return Mal.T;
procedure Find_Next_Token;
-- Search next token from index Last + 1.
@ -24,10 +25,9 @@ package body Reader is
-- Read_Atom has been merged into the same case/switch
-- statement, for clarity and efficiency.
function Read_List (Ending : in Character) return Types.Mal_Type_Array
with Inline;
function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type
function Read_List (Ending : in Character) return Mal.T_Array
with Inline;
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline;
----------------------------------------------------------------------
procedure Find_Next_Token
@ -61,7 +61,7 @@ package body Reader is
Last := First + 1;
loop
if Source'Last < Last then
raise Reader_Error with "expected '""'";
raise Reader_Error with "unbalanced '""'";
end if;
exit when Source (Last) = '"';
if Source (Last) = '\' then
@ -96,126 +96,108 @@ package body Reader is
end loop;
end Find_Next_Token;
function Read_Form return Types.Mal_Type
is
use Types;
function Read_Form return Mal.T is
use Ada.Strings.Unbounded;
begin
case Source (First) is
when '(' =>
return (Kind_List, Atoms.No_Element,
Lists.Alloc (Read_List (')')));
return Lists.List (Read_List (')'));
when '[' =>
return (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Read_List (']')));
return Lists.Vector (Read_List (']'));
when '{' =>
return (Kind_Map, Atoms.No_Element,
Maps.Hash_Map (Read_List ('}')));
return Maps.Hash_Map (Read_List ('}'));
when '"' =>
declare
Buffer : String (First .. Last);
B_Last : Natural := Buffer'First - 1;
Buffer : Unbounded_String;
I : Positive := First + 1;
begin
while I <= Last - 1 loop
if Source (I) /= '\' or else I = Last - 1 then
B_Last := B_Last + 1;
Buffer (B_Last) := Source (I);
while I < Last loop
if Source (I) /= '\' or else I + 1 = Last then
Append (Buffer, Source (I));
else
case Source (I + 1) is
when '\' | '"' =>
B_Last := B_Last + 1;
Buffer (B_Last) := Source (I + 1);
I := I + 1;
Append (Buffer, Source (I));
when 'n' =>
B_Last := B_Last + 1;
Buffer (B_Last) := Ada.Characters.Latin_1.LF;
I := I + 1;
Append (Buffer, Ada.Characters.Latin_1.LF);
when others =>
B_Last := B_Last + 1;
Buffer (B_Last) := Source (I);
Append (Buffer, Source (I));
end case;
end if;
I := I + 1;
end loop;
return (Kind_String, Atoms.No_Element,
Strings.Alloc (Buffer (Buffer'First .. B_Last)));
return (Kind_String, Buffer);
end;
when ':' =>
return (Kind_Keyword, Atoms.No_Element,
Strings.Alloc (Source (First + 1 .. Last)));
return (Kind_Keyword,
To_Unbounded_String (Source (First + 1 .. Last)));
when '-' =>
if First < Last
and then (for all C of Source (First + 1 .. Last) =>
C in '0' .. '9')
then
return (Kind_Number, Atoms.No_Element,
Integer'Value (Source (First .. Last)));
return (Kind_Number, Integer'Value (Source (First .. Last)));
else
return (Kind_Symbol, Atoms.No_Element,
Strings.Alloc (Source (First .. Last)));
return (Kind_Symbol,
Symbols.Constructor (Source (First .. Last)));
end if;
when '0' .. '9' =>
return (Kind_Number, Atoms.No_Element,
Integer'Value (Source (First .. Last)));
return (Kind_Number, Integer'Value (Source (First .. Last)));
when ''' =>
return Read_Quote (Names.Quote);
return Read_Quote (Symbols.Names.Quote);
when '`' =>
return Read_Quote (Names.Quasiquote);
return Read_Quote (Symbols.Names.Quasiquote);
when '@' =>
return Read_Quote (Names.Deref);
return Read_Quote (Symbols.Names.Deref);
when '~' =>
if First = Last then
return Read_Quote (Names.Unquote);
return Read_Quote (Symbols.Names.Unquote);
else
return Read_Quote (Names.Splice_Unquote);
return Read_Quote (Symbols.Names.Splice_Unquote);
end if;
when '^' =>
return Result : constant Mal_Type
:= (Kind_List, Atoms.No_Element, Lists.Alloc (3))
do
Result.L.Replace_Element (1, Mal_Type'
(Kind_Symbol, Atoms.No_Element, Names.With_Meta));
declare
Args : Mal.T_Array (1 .. 3);
begin
Args (1) := (Kind_Symbol, Symbols.Names.With_Meta);
Find_Next_Token;
if Source'Last < First then
raise Reader_Error with "Unfinished 'with-meta'";
end if;
Result.L.Replace_Element (3, Read_Form);
Args (3) := Read_Form;
Find_Next_Token;
if Source'Last < First then
raise Reader_Error with "Unfinished 'with-meta'";
end if;
Result.L.Replace_Element (2, Read_Form);
end return;
Args (2) := Read_Form;
return Lists.List (Args);
end;
when others =>
if Source (First .. Last) = "nil" then
return (Kind_Nil, Atoms.No_Element);
if Source (First .. Last) = "false" then
return (Kind_Boolean, False);
elsif Source (First .. Last) = "nil" then
return Mal.Nil;
elsif Source (First .. Last) = "true" then
return (Kind_Boolean, Atoms.No_Element, True);
elsif Source (First .. Last) = "false" then
return (Kind_Boolean, Atoms.No_Element, False);
return (Kind_Boolean, True);
else
return (Kind_Symbol, Atoms.No_Element,
Strings.Alloc (Source (First .. Last)));
return (Kind_Symbol,
Symbols.Constructor (Source (First .. Last)));
end if;
end case;
end Read_Form;
function Read_List (Ending : in Character) return Types.Mal_Type_Array
is
function Read_List (Ending : in Character) return Mal.T_Array is
-- Using big arrays on the stack is faster than doing
-- repeated dynamic reallocations.
Buffer : Types.Mal_Type_Array (First + 1 .. Source'Last);
Buffer : Mal.T_Array (First + 1 .. Source'Last);
B_Last : Natural := Buffer'First - 1;
begin
loop
Find_Next_Token;
if Source'Last < First then
raise Reader_Error with "expected '" & Ending & "'";
raise Reader_Error with "unbalanced '" & Ending & "'";
end if;
exit when Source (First) = Ending;
B_Last := B_Last + 1;
@ -224,19 +206,13 @@ package body Reader is
return Buffer (Buffer'First .. B_Last);
end Read_List;
function Read_Quote (Symbol : in Strings.Ptr) return Types.Mal_Type is
use Types;
Result : constant Mal_Type
:= (Kind_List, Atoms.No_Element, Lists.Alloc (2));
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is
begin
Result.L.Replace_Element (1,
Mal_Type'(Kind_Symbol, Atoms.No_Element, Symbol));
Find_Next_Token;
if Source'Last < First then
raise Reader_Error with "Unfinished '" & Symbol.Deref & "'";
raise Reader_Error with "Unfinished '" & Symbol.To_String & "'";
end if;
Result.L.Replace_Element (2, Read_Form);
return Result;
return Lists.List (Mal.T_Array'((Kind_Symbol, Symbol), Read_Form));
end Read_Quote;
----------------------------------------------------------------------
@ -244,7 +220,7 @@ package body Reader is
begin
Find_Next_Token;
if Source'Last < First then
raise Empty_Source;
raise Empty_Source with "attempting to read an empty line";
end if;
return Read_Form;
end Read_Str;

8
ada2/reader.ads
View File

@ -1,10 +1,8 @@
with Types;
with Types.Mal;
package Reader is
package Reader with Elaborate_Body is
pragma Elaborate_Body;
function Read_Str (Source : in String) return Types.Mal_Type;
function Read_Str (Source : in String) return Types.Mal.T;
Empty_Source : exception;
Reader_Error : exception;

47
ada2/step0_repl.adb
View File

@ -1,57 +1,48 @@
with Ada.Exceptions;
with Ada.Text_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Interfaces.C.Strings;
procedure Step0_Repl is
function Read (Source : in String) return String
is (Source);
subtype Mal_Type is String;
function Eval (Ast : in String) return String
is (Ast);
function Read (Source : in String) return Mal_Type
is (Source);
function Print (Ast : in String) return String
is (Ast);
function Eval (Ast : in Mal_Type) return Mal_Type
is (Ast);
function Print (Ast : in Mal_Type) return String
is (Ast);
function Rep (Source : in String) return String
is (Print (Eval (Read (Source))));
is (Print (Eval (Read (Source)))) with Inline;
procedure Interactive_Loop;
----------------------------------------------------------------------
procedure Interactive_Loop
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
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));
exception
when E : others =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
end;
end loop;
Ada.Text_IO.New_Line;

56
ada2/step1_read_print.adb
View File

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

170
ada2/step2_eval.adb
View File

@ -3,142 +3,122 @@ with Ada.Exceptions;
with Ada.Strings.Hash;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Lists;
with Interfaces.C.Strings;
with Printer;
with Reader;
with Types;
with Types.Builtins;
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
(Key_Type => String,
Element_Type => Types.Native_Function_Access,
Element_Type => Builtins.Ptr,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=",
"=" => Types."=");
function Read (Source : in String) return Types.Mal_Type
renames Reader.Read_Str;
function Eval (Ast : in Types.Mal_Type;
Env : in out Environments.Map) return Types.Mal_Type;
Unable_To_Call : exception;
"=" => Builtins."=");
Unknown_Symbol : exception;
function Print (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Read (Source : in String) return Mal.T
renames Reader.Read_Str;
function Eval (Ast : in Mal.T;
Env : in Environments.Map) return Mal.T;
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in out Environments.Map)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
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 out Environments.Map)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Map);
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Types.Mal_Type_Array)
return Types.Mal_Type;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_Elements is new Lists.Generic_Eval (Environments.Map, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Map, Eval);
----------------------------------------------------------------------
function Eval (Ast : in Types.Mal_Type;
Env : in out Environments.Map) return Types.Mal_Type
is
use Types;
function Eval (Ast : in Mal.T;
Env : in Environments.Map) return Mal.T is
First : Mal.T;
begin
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
declare
S : constant String := Ast.S.Deref;
S : constant String := Ast.Symbol.To_String;
C : constant Environments.Cursor := Env.Find (S);
begin
if Environments.Has_Element (C) then
return (Kind_Native, Atoms.No_Element,
Environments.Element (C));
return (Kind_Builtin, Environments.Element (C));
else
-- The predefined message does not pass tests.
raise Unknown_Symbol with "'" & S & "' not found";
end if;
end;
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
-- Apply phase
declare
First : constant Mal_Type := Eval (Ast.L.Element (1), Env);
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
First := Eval (Ast.L.Element (1), Env);
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
function Generic_Mal_Operator (Args : in Types.Mal_Type_Array)
return Types.Mal_Type
is (Types.Kind_Number, Atoms.No_Element,
Ada_Operator (Args (Args'First).Integer_Value,
Args (Args'First + 1).Integer_Value));
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));
procedure Interactive_Loop (Repl : in out Environments.Map)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -148,9 +128,10 @@ procedure Step2_Eval is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Unknown_Symbol =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
@ -165,11 +146,10 @@ procedure Step2_Eval is
Repl : Environments.Map;
begin
Repl.Include ("+", Addition 'Unrestricted_Access);
Repl.Include ("-", Subtraction'Unrestricted_Access);
Repl.Include ("*", Product 'Unrestricted_Access);
Repl.Include ("/", Division 'Unrestricted_Access);
Repl.Insert ("+", Addition 'Unrestricted_Access);
Repl.Insert ("-", Subtraction'Unrestricted_Access);
Repl.Insert ("*", Product 'Unrestricted_Access);
Repl.Insert ("/", Division 'Unrestricted_Access);
Interactive_Loop (Repl);
pragma Unreferenced (Repl);
end Step2_Eval;

239
ada2/step3_env.adb
View File

@ -1,163 +1,149 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step3_Env is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Print (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
generic
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Types.Mal_Type_Array)
return Types.Mal_Type;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
----------------------------------------------------------------------
function Eval (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
First : Mal_Type;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T is
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;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
end return;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Env);
begin
New_Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
New_Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), New_Env));
end loop;
return Eval (Ast.L.Element (3), New_Env);
end;
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.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;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
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);
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
function Generic_Mal_Operator (Args : in Types.Mal_Type_Array)
return Types.Mal_Type
is (Types.Kind_Number, Atoms.No_Element,
Ada_Operator (Args (Args'First).Integer_Value,
Args (Args'First + 1).Integer_Value));
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));
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -167,9 +153,10 @@ procedure Step3_Env is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
@ -182,18 +169,14 @@ procedure Step3_Env is
function Product is new Generic_Mal_Operator ("*");
function Division is new Generic_Mal_Operator ("/");
use Types;
Repl : constant Environments.Ptr := Environments.Alloc;
function S (Source : in String) return Symbols.Ptr
renames Symbols.Constructor;
Repl : Environments.Ptr renames Environments.Repl;
begin
Repl.Increase_Capacity (4);
Repl.Set (Names.Plus, Types.Mal_Type'
(Types.Kind_Native, Atoms.No_Element, Addition'Unrestricted_Access));
Repl.Set (Names.Minus, Types.Mal_Type'
(Types.Kind_Native, Atoms.No_Element, Subtraction'Unrestricted_Access));
Repl.Set (Names.Asterisk, Types.Mal_Type'
(Types.Kind_Native, Atoms.No_Element, Product'Unrestricted_Access));
Repl.Set (Names.Slash, Types.Mal_Type'
(Types.Kind_Native, Atoms.No_Element, Division'Unrestricted_Access));
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);
end Step3_Env;

324
ada2/step4_if_fn_do.adb
View File

@ -1,208 +1,197 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step4_If_Fn_Do is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Print (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
First : Mal_Type;
function Eval (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T is
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;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
end return;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
return Eval (Ast.L.Element (Ast.L.Length), Env);
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
return Eval (Ast.L.Element (3), Env);
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
return Eval (Ast.L.Element (4), Env);
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Env);
begin
New_Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
New_Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), New_Env));
end loop;
return Eval (Ast.L.Element (3), New_Env);
end;
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
if First.Kind /= Kind_Symbol then
-- Evaluate First, in the less frequent case where it is
-- not a symbol.
First := Eval (First, Env);
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
elsif First.Symbol = Symbols.Names.Def then
if Ast.L.Length /= 3 then
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when Kind_Function =>
declare
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => First.Environment);
begin
New_Env.Set_Binds (First.Formals, Args);
return Eval (First.Expression.Deref, New_Env);
end;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
return Eval (Ast.L.Element (Ast.L.Length), Env);
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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 Mal.Nil;
else
return Eval (Ast.L.Element (4), Env);
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.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;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
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);
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.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.Sub;
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
First.Function_Value.Set_Binds (New_Env, Args);
return Eval (First.Function_Value.Expression, New_Env);
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -212,9 +201,10 @@ procedure Step4_If_Fn_Do is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
@ -222,10 +212,12 @@ procedure Step4_If_Fn_Do is
----------------------------------------------------------------------
Repl : constant Environments.Ptr := Environments.Alloc;
Startup : constant String := "(do"
& "(def! not (fn* (a) (if a false true)))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
Interactive_Loop (Repl);
end Step4_If_Fn_Do;

332
ada2/step5_tco.adb
View File

@ -1,211 +1,206 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step5_Tco is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Print (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
First : Mal_Type;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
end return;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when Kind_Function =>
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -215,9 +210,10 @@ procedure Step5_Tco is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
@ -225,10 +221,12 @@ procedure Step5_Tco is
----------------------------------------------------------------------
Repl : constant Environments.Ptr := Environments.Alloc;
Startup : constant String := "(do"
& "(def! not (fn* (a) (if a false true)))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
Interactive_Loop (Repl);
end Step5_Tco;

368
ada2/step6_file.adb
View File

@ -2,214 +2,206 @@ with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step6_File is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Print (Ast : in Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
-- Eval, with a profile compatible with Native_Function_Access.
function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type;
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
First : Mal_Type;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
end return;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when Kind_Function =>
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -219,9 +211,10 @@ procedure Step6_File is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
@ -229,32 +222,27 @@ procedure Step6_File is
----------------------------------------------------------------------
use Types;
Argv : Mal_Type (Kind_List);
Repl : constant Environments.Ptr := Environments.Alloc;
function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is
(Eval (Args (Args'First), Repl));
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;
use Ada.Command_Line;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element,
Eval_Native'Unrestricted_Access));
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Discard (Eval (Read ("(def! load-file (fn* (f) "
& "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl));
if Ada.Command_Line.Argument_Count = 0 then
Repl.Set (Names.Argv, Argv);
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
else
Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1);
for I in 2 .. Ada.Command_Line.Argument_Count loop
Argv.L.Replace_Element (I - 1,
Mal_Type'(Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Command_Line.Argument (I))));
end loop;
Repl.Set (Names.Argv, Argv);
Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1)
& """)"), Repl));
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
end if;
end Step6_File;

461
ada2/step7_quote.adb
View File

@ -1,236 +1,227 @@
with Ada.Containers.Vectors;
with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types; use type Types.Kind_Type;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step7_Quote is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
with Inline;
Env : in Environments.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
-- 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 Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
-- Eval, with a profile compatible with Native_Function_Access.
function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type;
package Mal_Type_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Types.Mal_Type,
"=" => Types."=");
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
First : Mal_Type;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Environments.Ptr := Env0.Copy_Pointer;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
end return;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif First.S = Names.Quote then
pragma Assert (Ast.L.Length = 2);
return Ast.L.Element (2);
elsif First.S = Names.Quasiquote then
pragma Assert (Ast.L.Length = 2);
return Quasiquote (Ast.L.Element (2), Env);
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.Element (2).Kind not in Kind_List | Kind_Vector then
raise Argument_Error with "let*: expects a list or vector";
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
case First.Kind is
when Kind_Native =>
return First.Native.all (Args);
when Kind_Function =>
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
declare
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
end;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
goto Restart;
end;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -240,87 +231,77 @@ procedure Step7_Quote is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
is (case Ast.Kind is
when Types.Kind_Vector =>
(Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Types.Kind_List =>
when Kind_Vector => Quasiquote (Ast.L, Env),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Kind_List =>
(if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Types.Kind_Symbol
and then Ast.L.Element (1).S = Names.Unquote
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
then Eval (Ast.L.Element (2), Env)
else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))),
else Quasiquote (Ast.L, Env)),
when others => Ast);
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
is
use Types;
Buffer : Mal_Type_Vectors.Vector;
Elt : Mal_Type;
Env : in Environments.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
begin
for I in 1 .. List.Length loop
Elt := List.Element (I);
if Elt.Kind in Kind_List | Kind_Vector
and then 0 < Elt.L.Length
and then Elt.L.Element (1).Kind = Kind_Symbol
and then Elt.L.Element (1).S = Names.Splice_Unquote
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 = Symbols.Names.Splice_Unquote
then
pragma Assert (Elt.L.Length = 2);
Elt := Eval (Elt.L.Element (2), Env);
pragma Assert (Elt.Kind = Kind_List);
for J in 1 .. Elt.L.Length loop
Buffer.Append (Elt.L.Element (J));
end loop;
if R (I).L.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 argument";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
else
Buffer.Append (Quasiquote (Elt, Env));
R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env)));
end if;
end loop;
return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do
for I in 1 .. R.Length loop
R.Replace_Element (I, Buffer.Element (I));
end loop;
end return;
return Lists.Concat (R);
end Quasiquote;
----------------------------------------------------------------------
use Types;
Argv : Mal_Type (Kind_List);
Repl : constant Environments.Ptr := Environments.Alloc;
function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is
(Eval (Args (Args'First), Repl));
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;
use Ada.Command_Line;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element,
Eval_Native'Unrestricted_Access));
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Discard (Eval (Read ("(def! load-file (fn* (f) "
& "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl));
if Ada.Command_Line.Argument_Count = 0 then
Repl.Set (Names.Argv, Argv);
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
else
Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1);
for I in 2 .. Ada.Command_Line.Argument_Count loop
Argv.L.Replace_Element (I - 1,
Mal_Type'(Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Command_Line.Argument (I))));
end loop;
Repl.Set (Names.Argv, Argv);
Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1)
& """)"), Repl));
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
end if;
end Step7_Quote;

560
ada2/step8_macros.adb
View File

@ -1,282 +1,262 @@
with Ada.Containers.Vectors;
with Ada.Command_Line;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types; use type Types.Kind_Type;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step8_Macros is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
with Inline;
Env : in Environments.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
-- 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 Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
-- Eval, with a profile compatible with Native_Function_Access.
function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type;
package Mal_Type_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Types.Mal_Type,
"=" => Types."=");
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- 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;
First : Mal_Type;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.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);
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);
end return;
elsif First.S = Names.Defmacro then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
F : constant Mal_Type := Eval (Ast.L.Element (3), Env);
pragma Assert (F.Kind = Kind_Function);
begin
return R : constant Mal_Type
:= (Kind => Kind_Macro,
Meta => Atoms.No_Element,
Mac_Formals => F.Formals,
Mac_Expression => F.Expression)
do
Env.Set (Ast.L.Element (2).S, R);
end return;
end;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif First.S = Names.Macroexpand then
pragma Assert (Ast.L.Length = 2);
Macroexpanding := True;
Ast := Ast.L.Element (2);
goto Restart;
elsif First.S = Names.Quote then
pragma Assert (Ast.L.Length = 2);
return Ast.L.Element (2);
elsif First.S = Names.Quasiquote then
pragma Assert (Ast.L.Length = 2);
return Quasiquote (Ast.L.Element (2), Env);
end if;
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
case First.Kind is
when Kind_Native =>
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Native.all (Args);
when Kind_Function =>
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
goto Restart;
when Kind_Macro =>
for I in Args'Range loop
Args (I) := Ast.L.Element (I);
end loop;
declare
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Env);
begin
New_Env.Set_Binds (First.Mac_Formals, Args);
Ast := Eval (First.Mac_Expression.Deref, New_Env);
end;
if Macroexpanding then
return Ast;
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.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;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
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;
if Macroexpanding then
return Ast;
end if;
goto Restart;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -286,98 +266,88 @@ procedure Step8_Macros is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
-- Other exceptions are unexpected.
end;
end loop;
Ada.Text_IO.New_Line;
end Interactive_Loop;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
is (case Ast.Kind is
when Types.Kind_Vector =>
(Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Types.Kind_List =>
when Kind_Vector => Quasiquote (Ast.L, Env),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Kind_List =>
(if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Types.Kind_Symbol
and then Ast.L.Element (1).S = Names.Unquote
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
then Eval (Ast.L.Element (2), Env)
else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))),
else Quasiquote (Ast.L, Env)),
when others => Ast);
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
is
use Types;
Buffer : Mal_Type_Vectors.Vector;
Elt : Mal_Type;
Env : in Environments.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
begin
for I in 1 .. List.Length loop
Elt := List.Element (I);
if Elt.Kind in Kind_List | Kind_Vector
and then 0 < Elt.L.Length
and then Elt.L.Element (1).Kind = Kind_Symbol
and then Elt.L.Element (1).S = Names.Splice_Unquote
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 = Symbols.Names.Splice_Unquote
then
pragma Assert (Elt.L.Length = 2);
Elt := Eval (Elt.L.Element (2), Env);
pragma Assert (Elt.Kind = Kind_List);
for J in 1 .. Elt.L.Length loop
Buffer.Append (Elt.L.Element (J));
end loop;
if R (I).L.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 argument";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
else
Buffer.Append (Quasiquote (Elt, Env));
R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env)));
end if;
end loop;
return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do
for I in 1 .. R.Length loop
R.Replace_Element (I, Buffer.Element (I));
end loop;
end return;
return Lists.Concat (R);
end Quasiquote;
----------------------------------------------------------------------
use Types;
Argv : Mal_Type (Kind_List);
Repl : constant Environments.Ptr := Environments.Alloc;
function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is
(Eval (Args (Args'First), Repl));
Startup : constant String := "(do"
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
& "(defmacro! cond (fn* (& xs)"
& " (if (> (count xs) 0)"
& " (list 'if (first xs)"
& " (if (> (count xs) 1) (nth xs 1)"
& " (throw ""odd number of forms to cond""))"
& " (cons 'cond (rest (rest xs)))))))"
& "(defmacro! or (fn* (& xs)"
& " (if (empty? xs) nil"
& " (if (= 1 (count xs)) (first xs)"
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
use Ada.Command_Line;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element,
Eval_Native'Unrestricted_Access));
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Discard (Eval (Read ("(def! load-file (fn* (f) "
& "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl));
Discard (Eval (Read ("(defmacro! cond "
& "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) "
& "(if (> (count xs) 1) (nth xs 1) "
& "(throw ""odd number of forms to cond"")) "
& "(cons 'cond (rest (rest xs)))))))"), Repl));
Discard (Eval (Read ("(defmacro! or (fn* (& xs) "
& "(if (empty? xs) nil "
& "(if (= 1 (count xs)) (first xs) "
& "`(let* (or_FIXME ~(first xs)) "
& "(if or_FIXME or_FIXME "
& "(or ~@(rest xs))))))))"), Repl));
if Ada.Command_Line.Argument_Count = 0 then
Repl.Set (Names.Argv, Argv);
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
else
Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1);
for I in 2 .. Ada.Command_Line.Argument_Count loop
Argv.L.Replace_Element (I - 1,
Mal_Type'(Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Command_Line.Argument (I))));
end loop;
Repl.Set (Names.Argv, Argv);
Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1)
& """)"), Repl));
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
end if;
end Step8_Macros;

607
ada2/step9_try.adb
View File

@ -1,310 +1,303 @@
with Ada.Containers.Vectors;
with Ada.Command_Line;
with Ada.Exceptions; use type Ada.Exceptions.Exception_Id;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types; use type Types.Kind_Type;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure Step9_Try is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
with Inline;
Env : in Environments.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
-- 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 Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
-- Eval, with a profile compatible with Native_Function_Access.
function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type;
package Mal_Type_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Types.Mal_Type,
"=" => Types."=");
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- 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;
First : Mal_Type;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.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);
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);
end return;
elsif First.S = Names.Defmacro then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
F : constant Mal_Type := Eval (Ast.L.Element (3), Env);
pragma Assert (F.Kind = Kind_Function);
begin
return R : constant Mal_Type
:= (Kind => Kind_Macro,
Meta => Atoms.No_Element,
Mac_Formals => F.Formals,
Mac_Expression => F.Expression)
do
Env.Set (Ast.L.Element (2).S, R);
end return;
end;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif First.S = Names.Macroexpand then
pragma Assert (Ast.L.Length = 2);
Macroexpanding := True;
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.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;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.L.Length = 2 then
Ast := Ast.L.Element (2);
goto Restart;
elsif First.S = Names.Quote then
pragma Assert (Ast.L.Length = 2);
return Ast.L.Element (2);
elsif First.S = Names.Quasiquote then
pragma Assert (Ast.L.Length = 2);
return Quasiquote (Ast.L.Element (2), Env);
elsif First.S = Names.Try then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (3).Kind = Kind_List);
A3 : constant Lists.Ptr := Ast.L.Element (3).L;
pragma Assert (A3.Length = 3);
pragma Assert (A3.Element (1).Kind = Kind_Symbol);
pragma Assert (A3.Element (1).S = Names.Catch);
pragma Assert (A3.Element (2).Kind = Kind_Symbol);
elsif Ast.L.Length /= 3 then
raise Argument_Error with "try*: expects 1 or 2 arguments";
elsif Ast.L.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;
begin
if A3.Length /= 3 then
raise Argument_Error with "try*: arg 2 must have 3 elements";
elsif A3.Element (1).Kind /= Kind_Symbol
or else A3.Element (1).Symbol /= Symbols.Names.Catch
then
raise Argument_Error with "try*: arg 2 must be a catch*";
elsif A3.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "catch*: expects a symbol";
end if;
begin
return Eval (Ast.L.Element (2), Env);
exception
when E : others =>
Env.Replace_With_Subenv;
if Ada.Exceptions.Exception_Identity (E)
= Core.Exception_Throwed'Identity
then
Env.Set (A3.Element (2).S, Core.Last_Exception);
Core.Last_Exception := (Kind_Nil, Atoms.No_Element);
else
Env.Set (A3.Element (2).S, Mal_Type'
(Kind_String, Atoms.No_Element, Strings.Alloc
(Ada.Exceptions.Exception_Message (E))));
end if;
when E : Reader.Empty_Source | Argument_Error
| Reader.Reader_Error | Environments.Unknown_Key =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol,
Mal.T'(Kind_String, ASU.To_Unbounded_String
(Ada.Exceptions.Exception_Message (E))));
Ast := A3.Element (3);
goto Restart;
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.
end;
end if;
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
case First.Kind is
when Kind_Native =>
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Native.all (Args);
when Kind_Function =>
return First.Builtin.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
goto Restart;
when Kind_Macro =>
for I in Args'Range loop
Args (I) := Ast.L.Element (I);
end loop;
declare
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Env);
begin
New_Env.Set_Binds (First.Mac_Formals, Args);
Ast := Eval (First.Mac_Expression.Deref, New_Env);
end;
if Macroexpanding then
return Ast;
end if;
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
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;
if Macroexpanding then
return Ast;
end if;
goto Restart;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -314,98 +307,92 @@ procedure Step9_Try is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
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;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
is (case Ast.Kind is
when Types.Kind_Vector =>
(Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Types.Kind_List =>
when Kind_Vector => Quasiquote (Ast.L, Env),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Kind_List =>
(if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Types.Kind_Symbol
and then Ast.L.Element (1).S = Names.Unquote
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
then Eval (Ast.L.Element (2), Env)
else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))),
else Quasiquote (Ast.L, Env)),
when others => Ast);
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
is
use Types;
Buffer : Mal_Type_Vectors.Vector;
Elt : Mal_Type;
Env : in Environments.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
begin
for I in 1 .. List.Length loop
Elt := List.Element (I);
if Elt.Kind in Kind_List | Kind_Vector
and then 0 < Elt.L.Length
and then Elt.L.Element (1).Kind = Kind_Symbol
and then Elt.L.Element (1).S = Names.Splice_Unquote
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 = Symbols.Names.Splice_Unquote
then
pragma Assert (Elt.L.Length = 2);
Elt := Eval (Elt.L.Element (2), Env);
pragma Assert (Elt.Kind = Kind_List);
for J in 1 .. Elt.L.Length loop
Buffer.Append (Elt.L.Element (J));
end loop;
if R (I).L.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 argument";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
else
Buffer.Append (Quasiquote (Elt, Env));
R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env)));
end if;
end loop;
return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do
for I in 1 .. R.Length loop
R.Replace_Element (I, Buffer.Element (I));
end loop;
end return;
return Lists.Concat (R);
end Quasiquote;
----------------------------------------------------------------------
use Types;
Argv : Mal_Type (Kind_List);
Repl : constant Environments.Ptr := Environments.Alloc;
function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is
(Eval (Args (Args'First), Repl));
Startup : constant String := "(do"
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
& "(defmacro! cond (fn* (& xs)"
& " (if (> (count xs) 0)"
& " (list 'if (first xs)"
& " (if (> (count xs) 1) (nth xs 1)"
& " (throw ""odd number of forms to cond""))"
& " (cons 'cond (rest (rest xs)))))))"
& "(defmacro! or (fn* (& xs)"
& " (if (empty? xs) nil"
& " (if (= 1 (count xs)) (first xs)"
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
use Ada.Command_Line;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element,
Eval_Native'Unrestricted_Access));
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Discard (Eval (Read ("(def! load-file (fn* (f) "
& "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl));
Discard (Eval (Read ("(defmacro! cond "
& "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) "
& "(if (> (count xs) 1) (nth xs 1) "
& "(throw ""odd number of forms to cond"")) "
& "(cons 'cond (rest (rest xs)))))))"), Repl));
Discard (Eval (Read ("(defmacro! or (fn* (& xs) "
& "(if (empty? xs) nil "
& "(if (= 1 (count xs)) (first xs) "
& "`(let* (or_FIXME ~(first xs)) "
& "(if or_FIXME or_FIXME "
& "(or ~@(rest xs))))))))"), Repl));
if Ada.Command_Line.Argument_Count = 0 then
Repl.Set (Names.Argv, Argv);
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Lists.List (Args));
end;
if Argument_Count = 0 then
Interactive_Loop (Repl);
else
Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1);
for I in 2 .. Ada.Command_Line.Argument_Count loop
Argv.L.Replace_Element (I - 1,
Mal_Type'(Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Command_Line.Argument (I))));
end loop;
Repl.Set (Names.Argv, Argv);
Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1)
& """)"), Repl));
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
end if;
end Step9_Try;

621
ada2/stepa_mal.adb
View File

@ -1,310 +1,312 @@
with Ada.Containers.Vectors;
with Ada.Command_Line;
with Ada.Exceptions; use type Ada.Exceptions.Exception_Id;
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Interfaces.C.Strings; use type Interfaces.C.Strings.chars_ptr;
with Atoms;
with Interfaces.C.Strings;
with Core;
with Environments;
with Lists;
with Names;
with Printer;
with Reader;
with Strings; use type Strings.Ptr;
with Types; use type Types.Kind_Type;
with Types.Functions;
with Types.Lists;
with Types.Mal;
with Types.Maps;
with Types.Symbols.Names;
procedure StepA_Mal is
function Read (Source : in String) return Types.Mal_Type
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 Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type;
Unable_To_Call : exception;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type;
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T;
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
with Inline;
Env : in Environments.Ptr) return Mal.T with Inline;
-- Handle vectors and lists not starting with unquote.
-- 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 Types.Mal_Type;
Print_Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String
function Print (Ast : in Mal.T;
Readably : in Boolean := True) return ASU.Unbounded_String
renames Printer.Pr_Str;
function Rep (Source : in String;
Env : in Environments.Ptr)
return Ada.Strings.Unbounded.Unbounded_String
is (Print (Eval (Read (Source), Env)))
with Inline;
Env : in Environments.Ptr) return ASU.Unbounded_String
is (Print (Eval (Read (Source), Env))) with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr)
with Inline;
procedure Interactive_Loop (Repl : in Environments.Ptr);
function Eval_Elements is new Lists.Generic_Eval (Environments.Ptr, Eval);
function Eval_Elements is new Maps.Generic_Eval (Environments.Ptr, Eval);
-- Convenient when the result of eval is of no interest.
procedure Discard (Ast : in Types.Mal_Type) is null;
-- Eval, with a profile compatible with Native_Function_Access.
function Eval_Native (Args : in Types.Mal_Type_Array) return Types.Mal_Type;
package Mal_Type_Vectors is new Ada.Containers.Vectors
(Index_Type => Positive,
Element_Type => Types.Mal_Type,
"=" => Types."=");
procedure Discard (Ast : in Mal.T) is null;
----------------------------------------------------------------------
function Eval (Rec_Ast : in Types.Mal_Type;
Rec_Env : in Environments.Ptr) return Types.Mal_Type
is
use Types;
Ast : Types.Mal_Type := Rec_Ast;
Env : Environments.Ptr := Rec_Env;
function Eval (Ast0 : in Mal.T;
Env0 : in Environments.Ptr) return Mal.T is
-- 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;
First : Mal_Type;
First : Mal.T;
begin
<<Restart>>
<<Restart>>
-- Ada.Text_IO.New_Line;
-- Ada.Text_IO.Put ("EVAL: ");
-- Ada.Text_IO.Unbounded_IO.Put_Line (Print (Ast));
-- Environments.Dump_Stack;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_String
| Kind_Keyword | Kind_Macro | Kind_Function | Kind_Native =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.S);
return Env.Get (Ast.Symbol);
when Kind_Map =>
declare
function F (X : Mal_Type) return Mal_Type is (Eval (X, Env));
begin
return (Kind_Map, Atoms.No_Element, Ast.Map.Map (F'Access));
end;
return Eval_Elements (Ast.Map, Env);
when Kind_Vector =>
return R : constant Mal_Type := (Kind_Vector, Atoms.No_Element,
Lists.Alloc (Ast.L.Length))
do
for I in 1 .. Ast.L.Length loop
R.L.Replace_Element (I, Eval (Ast.L.Element (I), Env));
end loop;
end return;
return (Kind_Vector, Eval_Elements (Ast.L, Env));
when Kind_List =>
if Ast.L.Length = 0 then
return Ast;
end if;
First := Ast.L.Element (1);
-- Special forms
if First.Kind = Kind_Symbol then
if First.S = Names.Def then
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
return R : constant Mal_Type := Eval (Ast.L.Element (3), Env) do
Env.Set (Ast.L.Element (2).S, R);
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
raise Argument_Error with "def!: expects 2 arguments";
elsif Ast.L.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);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
if Ast.L.Length /= 3 then
raise Argument_Error with "defmacro!: expects 2 arguments";
elsif Ast.L.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);
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);
end return;
elsif First.S = Names.Defmacro then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (2).Kind = Kind_Symbol);
F : constant Mal_Type := Eval (Ast.L.Element (3), Env);
pragma Assert (F.Kind = Kind_Function);
begin
return R : constant Mal_Type
:= (Kind => Kind_Macro,
Meta => Atoms.No_Element,
Mac_Formals => F.Formals,
Mac_Expression => F.Expression)
do
Env.Set (Ast.L.Element (2).S, R);
end return;
end;
elsif First.S = Names.Mal_Do then
for I in 2 .. Ast.L.Length - 1 loop
Discard (Eval (Ast.L.Element (I), Env));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.S = Names.Fn then
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length =>
Ast.L.Element (2).L.Element (I).Kind = Kind_Symbol);
pragma Assert
(Ast.L.Element (2).L.Length < 1
or else Names.Ampersand /=
Ast.L.Element (2).L.Element (Ast.L.Element (2).L.Length).S);
pragma Assert
(for all I in 1 .. Ast.L.Element (2).L.Length - 2 =>
Ast.L.Element (2).L.Element (I).S /= Names.Ampersand);
return (Kind => Kind_Function,
Meta => Atoms.No_Element,
Formals => Ast.L.Element (2).L,
Expression => Atoms.Alloc (Ast.L.Element (3)),
Environment => Env);
elsif First.S = Names.Mal_If then
declare
pragma Assert (Ast.L.Length in 3 .. 4);
Test : constant Mal_Type := Eval (Ast.L.Element (2), Env);
begin
if (case Test.Kind is
when Kind_Nil => False,
when Kind_Boolean => Test.Boolean_Value,
when others => True)
then
Ast := Ast.L.Element (3);
goto Restart;
elsif Ast.L.Length = 3 then
return (Kind_Nil, Atoms.No_Element);
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.S = Names.Let then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert
(Ast.L.Element (2).Kind in Kind_List | Kind_Vector);
Bindings : constant Lists.Ptr := Ast.L.Element (2).L;
pragma Assert (Bindings.Length mod 2 = 0);
begin
Env.Replace_With_Subenv;
Env.Increase_Capacity (Bindings.Length / 2);
for I in 1 .. Bindings.Length / 2 loop
pragma Assert
(Bindings.Element (2 * I - 1).Kind = Kind_Symbol);
Env.Set (Bindings.Element (2 * I - 1).S,
Eval (Bindings.Element (2 * I), Env));
end loop;
end;
elsif First.Symbol = Symbols.Names.Mal_Do then
if Ast.L.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));
end loop;
Ast := Ast.L.Element (Ast.L.Length);
goto Restart;
elsif First.Symbol = Symbols.Names.Fn then
if Ast.L.Length /= 3 then
raise Argument_Error with "fn*: expects 3 arguments";
elsif Ast.L.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)
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);
elsif First.Symbol = Symbols.Names.Mal_If then
if Ast.L.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);
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);
goto Restart;
end;
elsif First.S = Names.Macroexpand then
pragma Assert (Ast.L.Length = 2);
Macroexpanding := True;
elsif Ast.L.Length = 3 then
return Mal.Nil;
else
Ast := Ast.L.Element (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
if Ast.L.Length /= 3 then
raise Argument_Error with "let*: expects 3 arguments";
elsif Ast.L.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;
begin
if Bindings.Length mod 2 /= 0 then
raise Argument_Error with "let*: odd number of bindings";
end if;
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
if Bindings.Element (2 * I - 1).Kind /= Kind_Symbol then
raise Argument_Error with "let*: keys must be symbols";
end if;
Env.Set (Bindings.Element (2 * I - 1).Symbol,
Eval (Bindings.Element (2 * I), Env));
end loop;
Ast := Ast.L.Element (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
if Ast.L.Length /= 2 then
raise Argument_Error with "macroexpand: expects 1 argument";
end if;
Macroexpanding := True;
Ast := Ast.L.Element (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quasiquote: expects 1 argument";
end if;
return Quasiquote (Ast.L.Element (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
if Ast.L.Length /= 2 then
raise Argument_Error with "quote: expects 1 argument";
end if;
return Ast.L.Element (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.L.Length = 2 then
Ast := Ast.L.Element (2);
goto Restart;
elsif First.S = Names.Quote then
pragma Assert (Ast.L.Length = 2);
return Ast.L.Element (2);
elsif First.S = Names.Quasiquote then
pragma Assert (Ast.L.Length = 2);
return Quasiquote (Ast.L.Element (2), Env);
elsif First.S = Names.Try then
declare
pragma Assert (Ast.L.Length = 3);
pragma Assert (Ast.L.Element (3).Kind = Kind_List);
A3 : constant Lists.Ptr := Ast.L.Element (3).L;
pragma Assert (A3.Length = 3);
pragma Assert (A3.Element (1).Kind = Kind_Symbol);
pragma Assert (A3.Element (1).S = Names.Catch);
pragma Assert (A3.Element (2).Kind = Kind_Symbol);
elsif Ast.L.Length /= 3 then
raise Argument_Error with "try*: expects 1 or 2 arguments";
elsif Ast.L.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;
begin
if A3.Length /= 3 then
raise Argument_Error with "try*: arg 2 must have 3 elements";
elsif A3.Element (1).Kind /= Kind_Symbol
or else A3.Element (1).Symbol /= Symbols.Names.Catch
then
raise Argument_Error with "try*: arg 2 must be a catch*";
elsif A3.Element (2).Kind /= Kind_Symbol then
raise Argument_Error with "catch*: expects a symbol";
end if;
begin
return Eval (Ast.L.Element (2), Env);
exception
when E : others =>
Env.Replace_With_Subenv;
if Ada.Exceptions.Exception_Identity (E)
= Core.Exception_Throwed'Identity
then
Env.Set (A3.Element (2).S, Core.Last_Exception);
Core.Last_Exception := (Kind_Nil, Atoms.No_Element);
else
Env.Set (A3.Element (2).S, Mal_Type'
(Kind_String, Atoms.No_Element, Strings.Alloc
(Ada.Exceptions.Exception_Message (E))));
end if;
when E : Reader.Empty_Source | Argument_Error
| Reader.Reader_Error | Environments.Unknown_Key =>
Env.Replace_With_Sub;
Env.Set (A3.Element (2).Symbol,
Mal.T'(Kind_String, ASU.To_Unbounded_String
(Ada.Exceptions.Exception_Message (E))));
Ast := A3.Element (3);
goto Restart;
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.
end;
end if;
end;
else
-- Equivalent to First := Eval (First, Env), except that
-- we already know enough to spare a recursive call in
-- this frequent case.
First := Env.Get (First.Symbol);
end if;
-- No special form has been found, attempt to apply the
-- first element to the rest of the list.
declare
Args : Mal_Type_Array (2 .. Ast.L.Length);
begin
First := Eval (First, Env);
case First.Kind is
when Kind_Native =>
-- Apply phase.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
return First.Native.all (Args);
when Kind_Function =>
return First.Builtin.all (Args);
end;
when Kind_Builtin_With_Meta =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
Env := Environments.Alloc (Outer => First.Environment);
Env.Set_Binds (First.Formals, Args);
Ast := First.Expression.Deref;
goto Restart;
when Kind_Macro =>
return First.Builtin_With_Meta.Data.all (Args);
end;
when Kind_Function =>
declare
Args : Mal.T_Array (2 .. Ast.L.Length);
begin
for I in Args'Range loop
Args (I) := Ast.L.Element (I);
Args (I) := Eval (Ast.L.Element (I), Env);
end loop;
declare
New_Env : constant Environments.Ptr
:= Environments.Alloc (Outer => Env);
begin
New_Env.Set_Binds (First.Mac_Formals, Args);
Ast := Eval (First.Mac_Expression.Deref, New_Env);
end;
if Macroexpanding then
return Ast;
end if;
Env.Replace_With_Sub (First.Function_Value.Closure);
First.Function_Value.Set_Binds (Env, Args);
Ast := First.Function_Value.Expression;
goto Restart;
when others =>
raise Unable_To_Call
with Ada.Strings.Unbounded.To_String (Print (First));
end case;
end;
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;
if Macroexpanding then
return Ast;
end if;
goto Restart;
when others =>
raise Argument_Error
with "cannot execute " & ASU.To_String (Print (First));
end case;
when others =>
return Ast;
end case;
end Eval;
procedure Interactive_Loop (Repl : in Environments.Ptr)
is
function Readline (Prompt : in Interfaces.C.char_array)
return Interfaces.C.Strings.chars_ptr
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 Interfaces.C.Strings.chars_ptr)
procedure Add_History (Line : in chars_ptr)
with Import, Convention => C, External_Name => "add_history";
procedure Free (Line : in Interfaces.C.Strings.chars_ptr)
procedure Free (Line : in chars_ptr)
with Import, Convention => C, External_Name => "free";
Prompt : constant Interfaces.C.char_array
:= Interfaces.C.To_C ("user> ");
C_Line : Interfaces.C.Strings.chars_ptr;
Prompt : constant char_array := To_C ("user> ");
C_Line : chars_ptr;
begin
loop
C_Line := Readline (Prompt);
exit when C_Line = Interfaces.C.Strings.Null_Ptr;
exit when C_Line = Null_Ptr;
declare
Line : constant String := Interfaces.C.Strings.Value (C_Line);
Line : constant String := Value (C_Line);
begin
if Line /= "" then
Add_History (C_Line);
@ -314,104 +316,99 @@ procedure StepA_Mal is
exception
when Reader.Empty_Source =>
null;
when E : others =>
when E : Argument_Error | Reader.Reader_Error
| Environments.Unknown_Key =>
Ada.Text_IO.Put_Line (Ada.Exceptions.Exception_Information (E));
-- but go on proceeding.
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;
function Quasiquote (Ast : in Types.Mal_Type;
Env : in Environments.Ptr) return Types.Mal_Type
function Quasiquote (Ast : in Mal.T;
Env : in Environments.Ptr) return Mal.T
is (case Ast.Kind is
when Types.Kind_Vector =>
(Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env)),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Types.Kind_List =>
when Kind_Vector => Quasiquote (Ast.L, Env),
-- When the test is updated, replace Kind_List with Kind_Vector.
when Kind_List =>
(if 0 < Ast.L.Length
and then Ast.L.Element (1).Kind = Types.Kind_Symbol
and then Ast.L.Element (1).S = Names.Unquote
and then Ast.L.Element (1).Kind = Kind_Symbol
and then Ast.L.Element (1).Symbol = Symbols.Names.Unquote
then Eval (Ast.L.Element (2), Env)
else (Types.Kind_List, Atoms.No_Element, Quasiquote (Ast.L, Env))),
else Quasiquote (Ast.L, Env)),
when others => Ast);
function Quasiquote (List : in Lists.Ptr;
Env : in Environments.Ptr) return Lists.Ptr
is
use Types;
Buffer : Mal_Type_Vectors.Vector;
Elt : Mal_Type;
Env : in Environments.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
begin
for I in 1 .. List.Length loop
Elt := List.Element (I);
if Elt.Kind in Kind_List | Kind_Vector
and then 0 < Elt.L.Length
and then Elt.L.Element (1).Kind = Kind_Symbol
and then Elt.L.Element (1).S = Names.Splice_Unquote
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 = Symbols.Names.Splice_Unquote
then
pragma Assert (Elt.L.Length = 2);
Elt := Eval (Elt.L.Element (2), Env);
pragma Assert (Elt.Kind = Kind_List);
for J in 1 .. Elt.L.Length loop
Buffer.Append (Elt.L.Element (J));
end loop;
if R (I).L.Length /= 2 then
raise Argument_Error with "splice-unquote: expects 1 argument";
end if;
R (I) := Eval (R (I).L.Element (2), Env);
if R (I).Kind /= Kind_List then
raise Argument_Error with "splice-unquote: expects a list";
end if;
else
Buffer.Append (Quasiquote (Elt, Env));
R (I) := Lists.List (Mal.T_Array'(1 => Quasiquote (R (I), Env)));
end if;
end loop;
return R : constant Lists.Ptr := Lists.Alloc (Natural (Buffer.Length)) do
for I in 1 .. R.Length loop
R.Replace_Element (I, Buffer.Element (I));
end loop;
end return;
return Lists.Concat (R);
end Quasiquote;
----------------------------------------------------------------------
use Types;
Argv : Mal_Type (Kind_List);
Repl : constant Environments.Ptr := Environments.Alloc;
function Eval_Native (Args : in Mal_Type_Array) return Mal_Type is
(Eval (Args (Args'First), Repl));
Startup : constant String := "(do"
& "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))"
& "(defmacro! cond (fn* (& xs)"
& " (if (> (count xs) 0)"
& " (list 'if (first xs)"
& " (if (> (count xs) 1) (nth xs 1)"
& " (throw ""odd number of forms to cond""))"
& " (cons 'cond (rest (rest xs)))))))"
& "(def! *gensym-counter* (atom 0))"
& "(def! gensym (fn* [] "
& " (symbol (str ""G__"" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"
& "(defmacro! or (fn* (& xs)"
& " (if (empty? xs) nil"
& " (if (= 1 (count xs)) (first xs)"
& " (let* (condvar (gensym))"
& " `(let* (~condvar ~(first xs))"
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
& "(def! *host-language* ""ada2"")"
& ")";
Repl : Environments.Ptr renames Environments.Repl;
use Ada.Command_Line;
begin
Core.Add_Built_In_Functions (Repl, Eval'Unrestricted_Access);
Repl.Set (Names.Eval, Mal_Type'(Kind_Native, Atoms.No_Element,
Eval_Native'Unrestricted_Access));
Discard (Eval (Read ("(def! not (fn* (a) (if a false true)))"), Repl));
Discard (Eval (Read ("(def! load-file (fn* (f) "
& "(eval (read-string (str ""(do "" (slurp f) "")"")))))"), Repl));
Discard (Eval (Read ("(defmacro! cond "
& "(fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) "
& "(if (> (count xs) 1) (nth xs 1) "
& "(throw ""odd number of forms to cond"")) "
& "(cons 'cond (rest (rest xs)))))))"), Repl));
Discard (Eval (Read ("(def! *gensym-counter* (atom 0))"), Repl));
Discard (Eval (Read ("(def! gensym (fn* [] (symbol (str ""G__"" "
& "(swap! *gensym-counter* (fn* [x] (+ 1 x)))))))"), Repl));
Discard (Eval (Read ("(defmacro! or (fn* (& xs) (if (empty? xs) nil "
& "(if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) "
& "`(let* (~condvar ~(first xs)) (if ~condvar ~condvar "
& "(or ~@(rest xs)))))))))"), Repl));
Repl.Set (Names.Host_Language,
Mal_Type'(Kind_Symbol, Atoms.No_Element, Names.Ada2));
if Ada.Command_Line.Argument_Count = 0 then
Repl.Set (Names.Argv, Argv);
Core.Eval_Ref := Eval'Unrestricted_Access;
Discard (Eval (Read (Startup), Repl));
declare
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
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);
else
Argv.L := Lists.Alloc (Ada.Command_Line.Argument_Count - 1);
for I in 2 .. Ada.Command_Line.Argument_Count loop
Argv.L.Replace_Element (I - 1,
Mal_Type'(Kind_String, Atoms.No_Element,
Strings.Alloc (Ada.Command_Line.Argument (I))));
end loop;
Repl.Set (Names.Argv, Argv);
Discard (Eval (Read ("(load-file """ & Ada.Command_Line.Argument (1)
& """)"), Repl));
Discard (Eval (Read ("(load-file """ & Argument (1) & """)"), Repl));
end if;
end StepA_Mal;

62
ada2/strings.adb
View File

@ -1,62 +0,0 @@
with Ada.Strings.Hash;
package body Strings is
Dict : Sets.Set;
Empty_Hash : constant Ada.Containers.Hash_Type := Ada.Strings.Hash ("");
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
if Sets.Has_Element (Object.Position) then
Dict (Object.Position).Refs := Dict (Object.Position).Refs + 1;
end if;
end Adjust;
function Alloc (Source : in String) return Ptr
is
Inserted : Boolean;
Position : Sets.Cursor;
begin
if Source /= "" then
Sets.Insert (Dict,
(Data => Source,
Hash => Ada.Strings.Hash (Source),
Last => Source'Length,
Refs => 1),
Position,
Inserted);
if not Inserted then
Dict (Position).Refs := Dict (Position).Refs + 1;
end if;
end if;
return (Ada.Finalization.Controlled with Position => Position);
end Alloc;
function Deref (Source : in Ptr) return String is
(if Sets.Has_Element (Source.Position)
then Dict (Source.Position).Data
else "");
procedure Finalize (Object : in out Ptr)
is
Refs : Positive;
begin
if Sets.Has_Element (Object.Position) then
Refs := Dict (Object.Position).Refs;
if 1 < Refs then
Dict (Object.Position).Refs := Refs - 1;
Object.Position := Sets.No_Element;
else
Sets.Delete (Dict, Object.Position);
end if;
end if;
end Finalize;
function Hash (Source : in Ptr) return Ada.Containers.Hash_Type is
(if Sets.Has_Element (Source.Position)
then Dict (Source.Position).Hash
else Empty_Hash);
end Strings;

65
ada2/strings.ads
View File

@ -1,65 +0,0 @@
with Ada.Containers;
private with Ada.Containers.Indefinite_Hashed_Sets;
private with Ada.Finalization;
package Strings is
pragma Elaborate_Body;
-- An abstraction similar to Ada.Strings.Unbounded, except that
-- the type is immutable, and that only one instance is allocated
-- with a given content. This avoids many allocations and
-- deallocations, since symbols and keywords are expected to be
-- used many times. Using this for all strings even if they are
-- not used as keys in maps should not hurt.
-- As a side effect, some frequent string comparisons (with "def!"
-- or "fn*" for example) will become a bit more efficient because
-- comparing pointers is faster than comparing strings.
type Ptr is tagged private;
Empty_String : constant Ptr; -- The default value.
function Alloc (Source : in String) return Ptr;
function Deref (Source : in Ptr) return String
with Inline;
-- We make the hash value visible so that environments and maps do
-- not need to recompute it.
function Hash (Source : in Ptr) return Ada.Containers.Hash_Type
with Inline;
private
type Element_Type (Last : Positive) is record
Data : String (1 .. Last);
Hash : Ada.Containers.Hash_Type;
Refs : Positive;
end record;
function Hash (Element : Element_Type) return Ada.Containers.Hash_Type
is (Element.Hash)
with Inline;
function Equivalent_Elements (Left, Right : Element_Type) return Boolean
is (Left.Data = Right.Data)
with Inline;
package Sets is new Ada.Containers.Indefinite_Hashed_Sets
(Element_Type => Element_Type,
Hash => Hash,
Equivalent_Elements => Equivalent_Elements,
"=" => "=");
type Ptr is new Ada.Finalization.Controlled with record
Position : Sets.Cursor := Sets.No_Element;
end record;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
-- Predefined equality is fine.
Empty_String : constant Ptr
:= (Ada.Finalization.Controlled with Position => Sets.No_Element);
end Strings;

62
ada2/types-atoms.adb Normal file
View File

@ -0,0 +1,62 @@
with Ada.Unchecked_Deallocation;
with Types.Mal;
package body Types.Atoms is
type Rec is limited record
Refs : Natural;
Data : Mal.T;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
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))));
function Deref (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "deref: expects 1 argument"
elsif Args (Args'First).Kind /= Kind_Atom then
raise Argument_Error with "deref: expects an atom"
else
(Args (Args'First).Atom.Ref.all.Data));
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;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
function Reset (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 2 then
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;
end Reset;
end Types.Atoms;

35
ada2/types-atoms.ads Normal file
View File

@ -0,0 +1,35 @@
private with Ada.Finalization;
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;
private
type Rec;
type Acc is access Rec;
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 Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
pragma Finalize_Storage_Only (Ptr);
end Types.Atoms;

53
ada2/types-builtins.adb Normal file
View File

@ -0,0 +1,53 @@
with Ada.Unchecked_Deallocation;
with Types.Mal;
package body Types.Builtins is
type Rec is limited record
Data : 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
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);
procedure Finalize (Object : in out Ptr_With_Meta) is
begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
Object.Ref.all.Refs := Object.Ref.all.Refs - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
function Meta (Item : in Ptr_With_Meta) return Mal.T
is (Item.Ref.all.Meta);
function With_Meta (Data : in Ptr;
Meta : in Mal.T) return Mal.T
is (Kind_Builtin_With_Meta, (Ada.Finalization.Controlled with new Rec'
(Data => Data,
Meta => Meta,
Refs => 1)));
function With_Meta (Data : in Ptr_With_Meta;
Meta : 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, Meta));
end Types.Builtins;

46
ada2/types-builtins.ads Normal file
View File

@ -0,0 +1,46 @@
private with Ada.Finalization;
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.
type Ptr_With_Meta 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 With_Meta (Data : in Ptr;
Meta : in Mal.T) return Mal.T with Inline;
function With_Meta (Data : in Ptr_With_Meta;
Meta : 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;
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
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);
end Types.Builtins;

171
ada2/types-functions.adb Normal file
View File

@ -0,0 +1,171 @@
with Ada.Strings.Unbounded;
with Ada.Unchecked_Deallocation;
with Environments;
with Printer;
with Types.Lists;
with Types.Mal;
with Types.Symbols.Names;
package body Types.Functions is
subtype AFC is Ada.Finalization.Controlled;
package ASU renames Ada.Strings.Unbounded;
use type Types.Symbols.Ptr;
type Rec is limited record
Refs : Natural := 1;
Args : Lists.Ptr;
Expr : Mal.T;
Env : Environments.Closure_Ptr;
Varargs : Boolean;
Meta : Mal.T := Mal.Nil;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
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 Expression (Item : in Ptr) return Mal.T
is (Item.Ref.all.Expr);
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;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
function Formals (Item : in Ptr) return Lists.Ptr
is (Item.Ref.all.Args);
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function New_Function (Formals : in Lists.Ptr;
Expression : in Mal.T;
Environment : in Environments.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 => <>)));
function New_Macro (Item : in Ptr) return Mal.T is
Old : Rec renames Item.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Item.Ref;
Old.Refs := 2;
Old.Env := Environments.Null_Closure;
-- Finalize the previous closure.
Old.Meta := Mal.Nil;
else
Ref := new Rec'(Args => Item.Ref.all.Args,
Expr => Item.Ref.all.Expr,
Varargs => Item.Ref.all.Varargs,
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;
Meta : in Mal.T)
return Mal.T is
Old : Rec renames Data.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Data.Ref;
Old.Refs := 2;
Old.Meta := Meta;
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 => Meta,
others => <>);
end if;
return (Kind_Function, (AFC with Ref));
end With_Meta;
end Types.Functions;

67
ada2/types-functions.ads Normal file
View File

@ -0,0 +1,67 @@
private with Ada.Finalization;
limited with Environments;
limited with Types.Lists;
limited with Types.Mal;
package Types.Functions 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 New_Function (Formals : in Lists.Ptr;
Expression : in Mal.T;
Environment : in Environments.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 Meta (Item : in Ptr) return Mal.T with inline;
function With_Meta (Data : in Ptr;
Meta : in Mal.T)
return Mal.T with Inline;
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
Ref : Acc := null;
end record
with Invariant => Ref /= null;
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.Functions;

260
ada2/types-lists.adb Normal file
View File

@ -0,0 +1,260 @@
with Ada.Unchecked_Deallocation;
with Types.Mal;
package body Types.Lists is
subtype AFC is Ada.Finalization.Controlled;
use type Mal.T_Array;
type Rec (Last : Natural) is limited record
Refs : Natural := 1;
Meta : Mal.T := Mal.Nil;
Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil);
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
----------------------------------------------------------------------
function "=" (Left, Right : in Ptr) return Boolean is
-- Should become Left.Ref.all.Data = Right.Ref.all.Data when
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
use type Mal.T;
L : Rec renames Left.Ref.all;
R : Rec renames Right.Ref.all;
begin
return L.Last = R.Last
and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I));
end "=";
function "&" (Left : in Mal.T_Array;
Right : in Ptr) return Mal.T_Array
is (Left & Right.Ref.all.Data);
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Concat (Args : in Mal.T_Array) return Mal.T is
Sum : Natural := 0;
Ref : Acc;
begin
for Arg of Args loop
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;
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;
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;
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";
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;
end Cons;
function Count (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "count: expects 1 argument"
else
(case Args (Args'First).Kind is
when Kind_Nil =>
(Kind_Number, 0),
when Kind_List | Kind_Vector =>
(Kind_Number, Args (Args'First).L.Ref.all.Last),
when others =>
raise Argument_Error with "count: expects a list or vector"));
function Element (Container : in Ptr;
Index : in Positive) return Mal.T
is (Container.Ref.all.Data (Index));
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;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
function First (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "first: expects 1 argument"
else
(case Args (Args'First).Kind is
when Kind_Nil =>
Mal.Nil,
when Kind_List | Kind_Vector =>
(if Args (Args'First).L.Ref.all.Last = 0 then
Mal.Nil
else
Args (Args'First).L.Ref.all.Data (1)),
when others =>
raise Argument_Error with "first: expects a list or vector"));
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Ptr is
-- Take care that automatic deallocation happens if an
-- exception is propagated by user code.
Old : Rec renames Container.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Container.Ref;
Old.Refs := 2;
Old.Meta := Mal.Nil;
else
Ref := new Rec (Old.Last);
end if;
return R : constant Ptr := (AFC with Ref) do
for I in Old.Data'Range loop
Ref.all.Data (I) := Eval (Old.Data (I), Env);
end loop;
end return;
end Generic_Eval;
function Is_Empty (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 1 then
raise Argument_Error with "empty?: expects 1 argument"
else
(case Args (Args'First).Kind is
when Kind_List | Kind_Vector =>
(Kind_Boolean, Args (Args'First).L.Ref.all.Last = 0),
when others =>
raise Argument_Error with "empty?: expects a list or vector"));
function Length (Source : in Ptr) return Natural
is (Source.Ref.all.Last);
function List (Args : in Mal.T_Array) return Mal.T
is (Kind_List, (AFC with new Rec'(Data => Args,
Last => Args'Length,
others => <>)));
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function Nth (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2 then
raise Argument_Error with "nth: expects 2 arguments"
else
(case Args (Args'First).Kind 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
then
Args (Args'First).L.Ref.all.Data
(1 + Args (Args'Last).Ada_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 Slice (Item : in Ptr;
Start : in Positive)
return Mal.T
is (Kind_List, (AFC with new Rec'
(Last => Item.Ref.all.Last - Start + 1,
Data => Item.Ref.all.Data (Start .. Item.Ref.all.Last),
others => <>)));
function Vector (Args : in Mal.T_Array) return Mal.T
is (Kind_Vector, (AFC with new Rec'(Data => Args,
Last => Args'Length,
others => <>)));
function With_Meta (Data : in Ptr;
Meta : in Mal.T)
return Ptr is
Old : Rec renames Data.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Data.Ref;
Old.Refs := 2;
Old.Meta := Meta;
else
Ref := new Rec'(Last => Old.Last,
Data => Old.Data,
Meta => Meta,
others => <>);
end if;
return (AFC with Ref);
end With_Meta;
end Types.Lists;

83
ada2/types-lists.ads Normal file
View File

@ -0,0 +1,83 @@
private with Ada.Finalization;
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;
function Conj (Args : in Mal.T_Array) return Mal.T;
function Cons (Args : in Mal.T_Array) return Mal.T;
function Count (Args : in Mal.T_Array) return Mal.T;
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 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;
function Length (Source : in Ptr) return Natural with Inline;
function Element (Container : in Ptr;
Index : in Positive) return Mal.T
with Inline;
Index_Error : exception;
function "&" (Left : in Mal.T_Array;
Right : in Ptr) return Mal.T_Array;
-- Used to implement Core.Apply.
-- Used to evaluate each element of a list/vector.
-- Eval is generic because units cannot depend on each other.
generic
type Env_Type (<>) is limited private;
with function Eval (Ast : in Mal.T;
Env : in Env_Type)
return Mal.T;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Ptr;
-- Used to spare an intermediate copy for & in macro arguments.
function Slice (Item : in Ptr;
Start : in Positive)
return Mal.T;
function Meta (Item : in Ptr) return Mal.T with Inline;
function With_Meta (Data : in Ptr;
Meta : in Mal.T)
return Ptr;
private
-- It is tempting to use null to represent an empty list, but the
-- performance is not improved much, and the code is more complex.
-- In addition, the empty list may want to carry metadata.
-- Similarly, always providing a default value like a pointer to a
-- static empty list would not gain much, and probably hide some
-- bugs.
type Rec;
type Acc is access Rec;
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 Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
overriding function "=" (Left, Right : in Ptr) return Boolean;
pragma Finalize_Storage_Only (Ptr);
end Types.Lists;

31
ada2/types-mal.adb Normal file
View File

@ -0,0 +1,31 @@
package body Types.Mal is
use type Ada.Strings.Unbounded.Unbounded_String;
use type Lists.Ptr;
use type Maps.Ptr;
use type Symbols.Ptr;
----------------------------------------------------------------------
function "=" (Left, Right : in T) return Boolean
is (case Left.Kind is
when Kind_Nil =>
Right.Kind = Kind_Nil,
when Kind_Boolean =>
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,
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,
when Kind_Map =>
Right.Kind = Kind_Map and then Left.Map = Right.Map,
when others =>
False);
end Types.Mal;

84
ada2/types-mal.ads Normal file
View File

@ -0,0 +1,84 @@
with Ada.Strings.Unbounded;
with Types.Atoms;
with Types.Builtins;
with Types.Functions;
with Types.Lists;
with Types.Maps;
with Types.Symbols;
package Types.Mal is
-- A type with a default value for the discriminant is the Ada
-- equivalent of a C union. It uses a fixed size, and allows
-- efficient arrays. A class hierarchy would make this impossible,
-- for little gain.
-- Native types may seem to consume too much memory, but
-- 1/ they require no allocation/deallocation.
-- 2/ the overhead would actually be higher with an intermediate
-- reference (the size of the pointer plus the size of the native
-- type, while an union uses the minimum of both and a single
-- memory area ).
-- Each instance has the size required for the largest possible
-- value, so subtypes should attempt to reduce their size when
-- possible (see Types.Symbols for such a compromise).
-- The idea is inspired from the Haskell and OCaml interpreters,
-- which use a bit to distinguish pointers from integers. Ada
-- allows to specify the bit position of each component, but
-- generating such architecture-dependent definitions seems a lot
-- of work for MAL.
-- The Ada tradition is to give explicit names to types, but this
-- one will be used very often, and almost each package declares
-- an "use Types;" clause, so Mal.T will do.
-- The only problem with a hidden discriminant is that "in out"
-- parameters cannot be reaffected with a different discriminant.
-- Eval would be more efficient with "in out" parameters than with
-- "in" parameters and a result, because lots of reference
-- counting would be spared, and the implementation would be able
-- to reuse dynamic memory more efficiently. Environments, and
-- some list/map operations already attempt such reuse behind the
-- curtain.
-- This would obfuscate the implementation of a functional
-- language, and require deep changes (the discriminant can be
-- changed for an in out or access parameter).
type T (Kind : Kind_Type := Kind_Nil) is record
case Kind is
when Kind_Nil =>
null;
when Kind_Boolean =>
Ada_Boolean : Boolean;
when Kind_Number =>
Ada_Number : Integer;
when Kind_Atom =>
Atom : Atoms.Ptr;
when Kind_Keyword | Kind_String =>
S : Ada.Strings.Unbounded.Unbounded_String;
when Kind_Symbol =>
Symbol : Symbols.Ptr;
when Kind_List | Kind_Vector =>
L : Lists.Ptr;
when Kind_Map =>
Map : Maps.Ptr;
when Kind_Builtin =>
Builtin : Builtins.Ptr;
when Kind_Builtin_With_Meta =>
Builtin_With_Meta : Builtins.Ptr_With_Meta;
when Kind_Function | Kind_Macro =>
Function_Value : Functions.Ptr;
end case;
end record;
-- Useful for recursive automatic definition of equality for
-- composite types like the array type below.
function "=" (Left, Right : in T) return Boolean with Inline;
Nil : constant T := (Kind => Kind_Nil);
type T_Array is array (Positive range <>) of T;
end Types.Mal;

266
ada2/types-maps.adb Normal file
View File

@ -0,0 +1,266 @@
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with Ada.Unchecked_Deallocation;
with Types.Lists;
with Types.Mal;
package body Types.Maps is
subtype AFC is Ada.Finalization.Controlled;
use type Ada.Containers.Count_Type;
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type
with Inline, Pre => Item.Kind in Kind_Keyword | Kind_String;
package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
Element_Type => Mal.T,
Hash => Hash,
Equivalent_Keys => Mal."=",
"=" => Mal."=");
use type HM.Map;
type Rec is limited record
Refs : Natural := 1;
Data : HM.Map := HM.Empty_Map;
Meta : Mal.T := Mal.Nil;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
----------------------------------------------------------------------
function "=" (Left, Right : in Ptr) return Boolean
is (Left.Ref.all.Data = Right.Ref.all.Data);
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Assoc (Args : in Mal.T_Array) return Mal.T is
Binds : constant Natural := Args'Length / 2;
begin
if Args'Length mod 2 /= 1 then
raise Argument_Error with "assoc: expects an odd argument count";
elsif Args (Args'First).Kind /= Kind_Map then
raise Argument_Error with "assoc: first argument must be a map";
elsif (for some I in 1 .. Binds => Args (Args'First + 2 * I - 1).Kind
not in Kind_Keyword | Kind_String)
then
raise Argument_Error with "assoc: keys must be strings or symbols";
end if;
declare
Old : Rec renames Args (Args'First).Map.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Args (Args'First).Map.Ref;
Old.Refs := 2;
Old.Meta := Mal.Nil;
else
Ref := new Rec'(Data => Old.Data, others => <>);
end if;
for I in 1 .. Binds loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
New_Item => Args (Args'First + 2 * I));
end loop;
return (Kind_Map, (AFC with Ref));
end;
end Assoc;
function Contains (Args : in Mal.T_Array) return Mal.T
is (if Args'Length /= 2 then
raise Argument_Error with "contains: expects 2 arguments"
elsif Args (Args'First).Kind /= Kind_Map then
raise Argument_Error with "contains: first arguement must be a map"
else (Kind_Boolean,
Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last))));
function Dissoc (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length = 0 then
raise Argument_Error with "dissoc: expects at least 1 argument";
elsif Args (Args'First).Kind /= Kind_Map then
raise Argument_Error with "dissoc: first argument must be a map";
elsif (for some I in Args'First + 1 .. Args'Last =>
Args (I).Kind not in Kind_Keyword | Kind_String)
then
raise Argument_Error with "dissoc: keys must be strings or symbols";
end if;
declare
Old : Rec renames Args (Args'First).Map.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Args (Args'First).Map.Ref;
Old.Refs := 2;
Old.Meta := Mal.Nil;
else
Ref := new Rec'(Data => Old.Data, others => <>);
end if;
for I in Args'First + 1 .. Args'Last loop
Ref.all.Data.Exclude (Args (I));
end loop;
return (Kind_Map, (AFC with Ref));
end;
end Dissoc;
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;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Free (Object.Ref);
end if;
end if;
end Finalize;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Mal.T is
-- Copy the whole hash in order to avoid recomputing the hash
-- for each key, even if it implies unneeded calls to adjust
-- and finalize for Mal_Type values.
Old : Rec renames Container.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Container.Ref;
Old.Refs := 2;
Old.Meta := Mal.Nil;
else
Ref := new Rec'(Data => Container.Ref.all.Data, others => <>);
end if;
-- Prepare a valid structure before running user code. In case
-- an exception is raised, we want memory to be deallocated.
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
for Position in Ref.all.Data.Iterate loop
Ref.all.Data.Replace_Element (Position,
Eval (HM.Element (Position), Env));
end loop;
end return;
end Generic_Eval;
function Get (Args : in Mal.T_Array) return Mal.T is
Position : HM.Cursor;
begin
if Args'Length /= 2 then
raise Argument_Error with "get: expects 2 arguments";
elsif Args (Args'Last).Kind not in Kind_Keyword | Kind_String then
raise Argument_Error with "get: key must be a keyword or string";
end if;
case Args (Args'First).Kind is
when Kind_Nil =>
return Mal.Nil;
when Kind_Map =>
Position
:= Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last));
if HM.Has_Element (Position) then
return HM.Element (Position);
else
return Mal.Nil;
end if;
when others =>
raise Argument_Error with "get: first argument must be a map";
end case;
end Get;
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type
is (Ada.Strings.Unbounded.Hash (Item.S));
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
Binds : constant Natural := Args'Length / 2;
Ref : Acc;
begin
if Args'Length mod 2 /= 0 then
raise Argument_Error with "hash-map: expects an even argument count";
elsif (for some I in 0 .. Binds - 1 => Args (Args'First + 2 * I).Kind
not in Kind_Keyword | Kind_String)
then
raise Argument_Error with "hash-map: keys must be strings or symbols";
end if;
Ref := new Rec;
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
for I in 0 .. Binds - 1 loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
New_Item => Args (Args'First + 2 * I + 1));
end loop;
return (Kind_Map, (AFC with Ref));
end Hash_Map;
procedure Iterate (Container : in Ptr) is
begin
for Position in Container.Ref.all.Data.Iterate loop
Process (HM.Key (Position), HM.Element (Position));
end loop;
end Iterate;
function Keys (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 1 then
raise Argument_Error with "keys: expects 1 argument";
elsif Args (Args'First).Kind /= Kind_Map then
raise Argument_Error with "keys: first argument must a map";
end if;
declare
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
R : Mal.T_Array (1 .. Natural (A1.Length));
I : Positive := 1;
begin
for Position in A1.Iterate loop
R (I) := HM.Key (Position);
I := I + 1;
end loop;
return Lists.List (R);
end;
end Keys;
function Meta (Container : in Ptr) return Mal.T
is (Container.Ref.all.Meta);
function Vals (Args : in Mal.T_Array) return Mal.T is
begin
if Args'Length /= 1 then
raise Argument_Error with "vals: expects 1 argument";
elsif Args (Args'First).Kind /= Kind_Map then
raise Argument_Error with "vals: first argument must be a map";
end if;
declare
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
R : Mal.T_Array (1 .. Natural (A1.Length));
I : Positive := 1;
begin
for Element of A1 loop
R (I) := Element;
I := I + 1;
end loop;
return Lists.List (R);
end;
end Vals;
function With_Meta (Data : in Ptr;
Meta : in Mal.T)
return Mal.T is
Old : Rec renames Data.Ref.all;
Ref : Acc;
begin
pragma Assert (0 < Old.Refs);
if Old.Refs = 1 then
Ref := Data.Ref;
Old.Refs := 2;
Old.Meta := Meta;
else
Ref := new Rec'(Data => Old.Data,
Meta => Meta,
others => <>);
end if;
return (Kind_Map, (AFC with Ref));
end With_Meta;
end Types.Maps;

68
ada2/types-maps.ads Normal file
View File

@ -0,0 +1,68 @@
private with Ada.Finalization;
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;
function Contains (Args : in Mal.T_Array) return Mal.T;
function Dissoc (Args : in Mal.T_Array) return Mal.T;
function Get (Args : in Mal.T_Array) return Mal.T;
function Hash_Map (Args : in Mal.T_Array) return Mal.T;
function Keys (Args : in Mal.T_Array) return Mal.T;
function Vals (Args : in Mal.T_Array) return Mal.T;
-- A generic is better than an access to function because of
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
-- Used to evaluate each element of a map.
-- Eval is generic because units cannot depend on each other.
generic
type Env_Type (<>) is limited private;
with function Eval (Ast : in Mal.T;
Env : in Env_Type)
return Mal.T;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Mal.T;
-- Used to print a map.
generic
with procedure Process (Key : in Mal.T;
Element : in Mal.T);
procedure Iterate (Container : in Ptr);
function Meta (Container : in Ptr) return Mal.T with Inline;
function With_Meta (Data : in Ptr;
Meta : in Mal.T)
return Mal.T;
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
Ref : Acc := null;
end record
with Invariant => Ref /= null;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
overriding function "=" (Left, Right : in Ptr) return Boolean with Inline;
pragma Finalize_Storage_Only (Ptr);
end Types.Maps;

31
ada2/types-symbols-names.ads Normal file
View File

@ -0,0 +1,31 @@
package Types.Symbols.Names is
-- These symbols are used once by Read/Eval/Print cycle. Declare
-- them here in order to avoid an allocation and a desallocation
-- during each call of eval.
-- The built-in functions declared in Core will remain allocated
-- during the lifetime of the program and do not require this.
-- A separate package is required because the constructor must be
-- callable, and a child package makes sense because without this
-- problem, these definition would be in Symbols.
Ampersand : constant Ptr := Constructor ("&");
Catch : constant Ptr := Constructor ("catch*");
Def : constant Ptr := Constructor ("def!");
Defmacro : constant Ptr := Constructor ("defmacro!");
Fn : constant Ptr := Constructor ("fn*");
Let : constant Ptr := Constructor ("let*");
Macroexpand : constant Ptr := Constructor ("macroexpand");
Mal_Do : constant Ptr := Constructor ("do");
Mal_If : constant Ptr := Constructor ("if");
Quasiquote : constant Ptr := Constructor ("quasiquote");
Quote : constant Ptr := Constructor ("quote");
Splice_Unquote : constant Ptr := Constructor ("splice-unquote");
Try : constant Ptr := Constructor ("try*");
Unquote : constant Ptr := Constructor ("unquote");
-- These are used by both Core and Reader. Spare a search.
Deref : constant Ptr := Constructor ("deref");
With_Meta : constant Ptr := Constructor ("with-meta");
end Types.Symbols.Names;

90
ada2/types-symbols.adb Normal file
View File

@ -0,0 +1,90 @@
with Ada.Containers.Ordered_Sets;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
package body Types.Symbols is
-- For the global dictionnary of symbols, an ordered set seems
-- better than a hash map.
type Rec (Last : Positive) is limited record
Refs : Natural;
Hash : Ada.Containers.Hash_Type;
Data : String (1 .. Last);
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
function "<" (Left, Right : in Acc) return Boolean with Inline;
function Eq (Left, Right : in Acc) return Boolean with Inline;
-- It would be unwise to name this function "=" and override the
-- predefined equality for Acc.
-- We only search by key and insert new elements, so this should
-- always return False.
package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc,
"<" => "<",
"=" => Eq);
function Key (Item : in Acc) return String with Inline;
package Keys is new Sets.Generic_Keys (Key_Type => String,
Key => Key,
"<" => Standard."<");
Dict : Sets.Set;
----------------------------------------------------------------------
function "<" (Left, Right : in Acc) return Boolean
is (Left.all.Data < Right.all.Data);
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := Object.Ref.all.Refs + 1;
end Adjust;
function Constructor (Source : in String) return Ptr is
Position : constant Sets.Cursor := Keys.Find (Dict, Source);
Ref : Acc;
begin
if Sets.Has_Element (Position) then
Ref := Sets.Element (Position);
Ref.all.Refs := Ref.all.Refs + 1;
else
Ref := new Rec'(Data => Source,
Hash => Ada.Strings.Hash (Source),
Last => Source'Length,
Refs => 1);
Dict.Insert (Ref);
end if;
return (Ada.Finalization.Controlled with Ref);
end Constructor;
function Eq (Left, Right : in Acc) return Boolean is
begin
pragma Assert (Left /= Right);
pragma Assert (Left.all.Data /= Right.all.Data);
return False;
end Eq;
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;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Dict.Delete (Object.Ref);
Free (Object.Ref);
end if;
end if;
end Finalize;
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
is (Item.Ref.all.Hash);
function Key (Item : in Acc) return String
is (Item.all.Data);
function To_String (Item : in Ptr) return String
is (Item.Ref.all.Data);
end Types.Symbols;

59
ada2/types-symbols.ads Normal file
View File

@ -0,0 +1,59 @@
with Ada.Containers;
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;
-- The hash value is made available because symbols have a high
-- probability to end up as keys in an environment.
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline;
-- Equality compares the contents.
private
-- Only one instance is allocated with a given content. This
-- avoids many allocations and deallocations, since symbols are
-- expected to be used many times.
-- Tests seem to show that this solution is a few percents faster
-- than Ada.Strings.Unbounded.
-- As a side effect, some frequent string comparisons (with "def!"
-- or "fn*" for example) will become a bit more efficient because
-- comparing pointers is faster than comparing strings.
-- It would be natural to store a Cursor from the global
-- dictionnary into Ptr, but this actually reduces the speed,
-- 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
Ref : Acc := null;
end record
with Invariant => Ref /= null;
overriding procedure Adjust (Object : in out Ptr) with Inline;
overriding procedure Finalize (Object : in out Ptr) with Inline;
-- Predefined equality is fine.
pragma Finalize_Storage_Only (Ptr);
end Types.Symbols;

37
ada2/types.adb
View File

@ -1,37 +0,0 @@
package body Types is
function "=" (Left, Right : in Mal_Type) return Boolean is
(case Left.Kind is
when Kind_Nil =>
Right.Kind = Kind_Nil,
when Kind_Atom =>
Right.Kind = Kind_Atom
and then Atoms."=" (Left.Reference, Right.Reference),
when Kind_Boolean =>
Right.Kind = Kind_Boolean
and then Left.Boolean_Value = Right.Boolean_Value,
when Kind_Number =>
Right.Kind = Kind_Number
and then Left.Integer_Value = Right.Integer_Value,
when Kind_String | Kind_Keyword | Kind_Symbol =>
Right.Kind = Left.Kind
and then Strings."=" (Left.S, Right.S),
when Kind_List | Kind_Vector =>
Right.Kind in Kind_List | Kind_Vector
and then Lists."=" (Left.L, Right.L),
when Kind_Map =>
Right.Kind = Kind_Map
and then Maps."=" (Left.Map, Right.Map),
when Kind_Function =>
Right.Kind = Kind_Function
and then Lists."=" (Left.Formals, Right.Formals)
and then Atoms."=" (Left.Expression, Right.Expression)
and then Environments."=" (Left.Environment, Right.Environment),
when Kind_Native =>
Right.Kind = Kind_Native and then Left.Native = Right.Native,
when Kind_Macro =>
Right.Kind = Kind_Macro
and then Atoms."=" (Left.Mac_Expression, Right.Mac_Expression)
and then Lists."=" (Left.Mac_Formals, Right.Mac_Formals));
end Types;

55
ada2/types.ads
View File

@ -1,17 +1,7 @@
with Atoms;
with Environments;
with Lists;
with Maps;
with Strings;
package Types with Pure is
package Types is
type Mal_Type;
type Mal_Type_Array;
type Native_Function_Access is not null access
function (Arguments : in Mal_Type_Array) return Mal_Type;
-- Make similar kinds consecutive for efficient case statements.
-- Similar kinds should be consecutive for efficient case
-- statements.
type Kind_Type is
(Kind_Nil,
Kind_Atom,
@ -20,40 +10,11 @@ package Types is
Kind_String, Kind_Symbol, Kind_Keyword,
Kind_List, Kind_Vector,
Kind_Map,
Kind_Macro, Kind_Function, Kind_Native);
Kind_Macro, Kind_Function, Kind_Builtin_With_Meta, Kind_Builtin);
type Mal_Type (Kind : Kind_Type := Kind_Nil) is record
Meta : Atoms.Ptr;
case Kind is
when Kind_Nil =>
null;
when Kind_Boolean =>
Boolean_Value : Boolean;
when Kind_Number =>
Integer_Value : Integer;
when Kind_Atom =>
Reference : Atoms.Ptr;
when Kind_String | Kind_Keyword | Kind_Symbol =>
S : Strings.Ptr;
when Kind_List | Kind_Vector =>
L : Lists.Ptr;
when Kind_Map =>
Map : Maps.Ptr;
when Kind_Native =>
Native : Native_Function_Access;
when Kind_Function =>
Formals : Lists.Ptr;
Expression : Atoms.Ptr;
Environment : Environments.Ptr;
when Kind_Macro =>
Mac_Formals : Lists.Ptr;
Mac_Expression : Atoms.Ptr;
end case;
end record;
function "=" (Left, Right : in Mal_Type) return Boolean;
-- By default, a list /= a vector.
type Mal_Type_Array is array (Positive range <>) of Types.Mal_Type;
-- Raised when a program attempts to execute something else than a
-- function or a macro, or when a builtin receives a bad argument
-- count, type or value.
Argument_Error : exception;
end Types;