kanaka/mal
1
1
Fork 0
mirror of https://github.com/kanaka/mal.git synced 2024-09-21 02:27:10 +03:00
Code Issues Projects Releases Wiki Activity

ada.2: fix memory leaks with garbage collection. Various simplifications.

Browse Source 
Cyclic references were never deallocated by reference conuting.
Symbols cannot create cyclic structures and are less frequent (one
allocation per symbol), keep reference counting for them.

This slightly improves performances even though many previous
optimizations are removed (environment stack, reuse of memory).

Step caching hash of symbols. This does not seem to improve
performances. Hashing them instead of ordering them does.

Define Repl in the step file instead of globally. Move the eval
built-in function from core into the step file.

When possible, pass Ada records instead of explicit pointers.

In the reader, construct more objects directly as described in the MAL
process, reserve the buffer for sequences and maps

In eval, iterate on vectors without delegation. The increased
complexity was not improving performances.  Keep demonstrating Ada
type-safe genericity for maps, where iterating outside Types.Maps
would be less easy and/or efficient.

In quasiquote_list, concatenate in one buffer instead of allocating a
list for each element. The buffer may be reallocated behind the
curtain, but not once per element anymore.

In environments, illustrate tail call optimization when recursion is
more readable than a loop.
This commit is contained in:
Nicolas Boulenguez 2019-03-31 19:06:00 +02:00
parent 6d9e1684de
commit 5a07bb5331
34 changed files with 1637 additions and 2064 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

1
ada.2/Makefile
View File

@ -37,6 +37,7 @@ TYPES := \
envs.ads envs.adb \
err.ads err.adb \
eval_cb.ads \
garbage_collected.ads garbage_collected.adb \
printer.ads printer.adb \
reader.ads reader.adb \
readline.ads \

37
ada.2/README
View File

@ -14,19 +14,19 @@ but also two crucial performance improvements:
* 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 allocated
memory when the reference count reaches 1...
Another difference is that a minimal form of garbage collecting is
implemented, removing objects not referenced from the main
environment. Reference counting is convenient for symbols or strings,
but never deallocates cyclic structures. The implementation collects
garbage after each Read-Eval-Print cycle. It would be much more
difficult to collect garbage inside scripts. If this is ever done, it
would be better to reimplement load-file in Ada and run a cycle after
each root evaluation.
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 count references in
recursive structures instead of a posteriori garbage collection.
Notes for contributors that do not fit in a specific package.
--
@ -35,24 +35,29 @@ Notes for contributors that do not fit in a specific package.
ensuring a valid value during elaboration.
Note that generic packages cannot export access values.
* All wrapped pointers are non null, new variables must be assigned
* Symbol pointers are non null, new variables must be assigned
immediately. This is usually enforced by a hidden discriminant, but
here we want the type to become a field inside Types.Mal.T. So the
check happens at run time with a private invariant.
* The finalize procedure may be called twice, so it does nothing when
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 the 'map' built-in function may run user code).
* In implementations with reference counting, a consistent object
(that will be deallocated automatically) must be built before any
exception is raised by user code (for example the 'map' built-in
function may run user code). Garbage collection simplifies a lot
this kind of situations.
* Each module encapsulating dynamic allocation counts allocations and
deallocations. With debugging options, a failure is reported if
- too many deallocation happen (via a numeric range check)
- all storage is not freed (via a dedicated call from the step file)
The main program only checks that the garbage collector removes all
allocations at the end of execution.
Debugging
--
@ -61,7 +66,5 @@ TCO cycles). This has become possible in step9, but has been
backported to former steps as this is really handy for debugging.
Some environment variables increase verbosity.
# dbg_reader= ./stepAmal trace reader recursion
# dbgeval= ./stepAmal eval recursion (or TCO)
# dbgenv0= ./stepAmal eval recursion and environments contents
# dbgenv1= ./stepAmal eval recursion and environment internals
# dbgread= ./stepAmal trace reader recursion
# dbgeval= ./stepAmal trace eval recursion (including TCO)

44
ada.2/core.adb
View File

@ -3,11 +3,10 @@ with Ada.Characters.Latin_1;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Envs;
with Err;
with Eval_Cb;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
@ -64,7 +63,6 @@ package body Core is
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);
@ -108,19 +106,19 @@ package body Core is
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
"last parameter must be a sequence");
declare
use type Sequences.Ptr;
use type Sequences.Instance;
F : Mal.T renames Args (Args'First);
A : constant Mal.T_Array
:= Args (Args'First + 1 .. Args'Last - 1)
& Args (Args'Last).Sequence;
& Args (Args'Last).Sequence.all;
begin
case F.Kind is
when Kind_Builtin =>
return F.Builtin.all (A);
when Kind_Builtin_With_Meta =>
return F.Builtin_With_Meta.Builtin.all (A);
return F.Builtin_With_Meta.all.Builtin.all (A);
when Kind_Fn =>
return F.Fn.Apply (A);
return F.Fn.all.Apply (A);
when others =>
Err.Raise_With ("parameter 1 must be a function");
end case;
@ -134,13 +132,6 @@ package body Core is
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
end Equals;
function Eval (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Ast => Args (Args'First),
Env => Envs.Repl);
end Eval;
function Is_False (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
@ -188,13 +179,13 @@ package body Core is
begin
case A1.Kind is
when Kind_Sequence =>
return A1.Sequence.Meta;
return A1.Sequence.all.Meta;
when Kind_Map =>
return A1.Map.Meta;
return A1.Map.all.Meta;
when Kind_Fn =>
return A1.Fn.Meta;
return A1.Fn.all.Meta;
when Kind_Builtin_With_Meta =>
return A1.Builtin_With_Meta.Meta;
return A1.Builtin_With_Meta.all.Meta;
when Kind_Builtin =>
return Mal.Nil;
when others =>
@ -203,14 +194,14 @@ package body Core is
end;
end Meta;
procedure NS_Add_To_Repl is
procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is
procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr) with Inline;
procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr)
is
begin
Envs.Repl.Set (S, (Kind_Builtin, B));
Repl.all.Set (S, (Kind_Builtin, B));
end P;
begin
P (Symbols.Constructor ("+"), Addition'Access);
@ -227,7 +218,6 @@ package body Core is
P (Symbols.Constructor ("/"), Division'Access);
P (Symbols.Constructor ("do"), Mal_Do'Access);
P (Symbols.Constructor ("="), Equals'Access);
P (Symbols.Constructor ("eval"), Eval'Access);
P (Symbols.Constructor ("first"), Sequences.First'Access);
P (Symbols.Constructor ("get"), Maps.Get'Access);
P (Symbols.Constructor (">="), Greater_Equal'Access);
@ -360,7 +350,7 @@ package body Core is
end;
end if;
when Kind_Sequence =>
if Args (Args'First).Sequence.Length = 0 then
if Args (Args'First).Sequence.all.Length = 0 then
return Mal.Nil;
else
return (Kind_List, Args (Args'First).Sequence);
@ -427,17 +417,17 @@ package body Core is
begin
case A1.Kind is
when Kind_Builtin_With_Meta =>
return A1.Builtin_With_Meta.With_Meta (A2);
return Builtins.With_Meta (A1.Builtin_With_Meta.all, A2);
when Kind_Builtin =>
return Builtins.With_Meta (A1.Builtin, A2);
when Kind_List =>
return (Kind_List, A1.Sequence.With_Meta (A2));
return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2));
when Kind_Vector =>
return (Kind_Vector, A1.Sequence.With_Meta (A2));
return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2));
when Kind_Map =>
return A1.Map.With_Meta (A2);
return Maps.With_Meta (A1.Map.all, A2);
when Kind_Fn =>
return A1.Fn.With_Meta (A2);
return Fns.With_Meta (A1.Fn.all, A2);
when others =>
Err.Raise_With
("parameter 1 must be a function, map or sequence");

6
ada.2/core.ads
View File

@ -1,6 +1,8 @@
with Envs;
package Core with Elaborate_Body is
procedure NS_Add_To_Repl;
-- Add built-in functions to Envs.Repl.
procedure NS_Add_To_Repl (Repl : in Envs.Ptr);
-- Add built-in functions.
end Core;

454
ada.2/envs.adb
View File

@ -1,6 +1,4 @@
with Ada.Containers.Hashed_Maps;
with Ada.Text_IO.Unbounded_IO;
with Ada.Unchecked_Deallocation;
with Err;
with Printer;
@ -11,417 +9,93 @@ package body Envs is
use Types;
-- The Eval built-in uses the REPL root environment (index 1),
-- all others parameters only repeat the top index.
package HM is new Ada.Containers.Hashed_Maps
(Key_Type => Symbols.Ptr,
Element_Type => Mal.T,
Hash => Symbols.Hash,
Equivalent_Keys => Symbols."=",
"=" => Mal."=");
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);
Allocations : Natural := 0;
procedure Unreference (Reference : in out Heap_Access);
procedure Set_Binds (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array);
----------------------------------------------------------------------
procedure Adjust (Object : in out Closure_Ptr) is
begin
if Object.Ref /= null then
Object.Ref.all.Refs := @ + 1;
end if;
end Adjust;
procedure Clear_And_Check_Allocations is
begin
pragma Assert (Top = 1);
pragma Assert (Stack (1).Refs = 1);
Stack (1).Data.Clear;
if Stack (1).Alias /= null then
if Stack (1).Alias.all.Refs /= 0 then
Dump_Stack (Long => True);
end if;
pragma Assert (Stack (1).Alias.all.Refs = 0);
Allocations := Allocations - 1;
Free (Stack (1).Alias);
end if;
pragma Assert (Allocations = 0);
end Clear_And_Check_Allocations;
function Copy_Pointer (Env : in Ptr) return Ptr is
pragma Assert (Env.Index in 1 | Top);
begin
Stack (Env.Index).Refs := @ + 1;
return (Ada.Finalization.Limited_Controlled with Env.Index);
end Copy_Pointer;
procedure Dump_Stack (Long : in Boolean) is
procedure Dump_Stack (Env : in Instance) is
use Ada.Text_IO;
begin
for I in 1 .. Top loop
if Long then
Put ("Level");
end if;
Put (I'Img);
if Long then
Put_Line ("environment:");
for P in Env.Data.Iterate loop
-- Do not print builtins for repl.
if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then
Put (" ");
Put (HM.Key (P).To_String);
Put (':');
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
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 or 1 < I then
Put (" ");
Put (HM.Key (P).To_String);
Put (':');
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
if Long then
New_Line;
end if;
end if;
end loop;
New_Line;
end loop;
if Env.Outer /= null then
Put ("outer is ");
Env.Outer.all.Dump_Stack;
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 := @ - 1;
end if;
Object.Index := 0;
-- If Index = Top and there are no more references.
loop
pragma Assert (0 < Top);
declare
R : Stack_Record renames Stack (Top);
begin
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);
Allocations := Allocations - 1;
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);
Allocations := Allocations - 1;
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
Allocations := Allocations + 1;
O.Alias := new Heap_Record'(Index => R.Outer_Index,
others => <>);
else
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;
Top := Top - 1;
end loop;
end if;
end Finalize;
function Get (Evt : in Ptr;
function Get (Env : in Instance;
Key : in Symbols.Ptr) return Mal.T
is
pragma Assert (Evt.Index in 1 | Top);
Index : Stack_Index := Evt.Index;
Ref : Heap_Access;
Definition : HM.Cursor;
-- Trust the compiler to detect the tail call. A loop would
-- require a Ptr parameter or a separated first iteration.
Position : constant HM.Cursor := Env.Data.Find (Key);
begin
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;
Err.Raise_With ("'" & Key.To_String & "' not found");
if HM.Has_Element (Position) then
return HM.Element (Position);
end if;
Err.Check (Env.Outer /= null,
"'" & Symbols.To_String (Key) & "' not found");
return Env.Outer.all.Get (Key);
end Get;
function New_Closure (Env : in Ptr'Class) return Closure_Ptr is
pragma Assert (Env.Index in 1 | Top);
Alias : Heap_Access renames Stack (Env.Index).Alias;
procedure Keep_References (Object : in out Instance) is
-- Same remarks than for Get.
begin
if Alias = null then
Allocations := Allocations + 1;
Alias := new Heap_Record'(Index => Env.Index, others => <>);
else
Alias.all.Refs := @ + 1;
for Element of Object.Data loop
Mal.Keep (Element);
end loop;
if Object.Outer /= null then
Object.Outer.all.Keep;
end if;
return (Ada.Finalization.Controlled with Alias);
end New_Closure;
end Keep_References;
procedure Replace_With_Sub (Env : in out Ptr) is
pragma Assert (Env.Index in 1 | Top);
R : Stack_Record renames Stack (Env.Index);
begin
if Env.Index < Top or 1 < R.Refs
or (R.Alias /= null and then 0 < R.Alias.all.Refs)
then
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;
-- Else reuse the top stack record, including its map and its
-- unreferenced alias if any.
end Replace_With_Sub;
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
is
pragma Assert (Env.Index in 1 | Top);
begin
-- Finalize Env before creating the new environment, in case
-- this is the last reference and it can be forgotten.
-- Automatic assignment would construct the new value before
-- finalizing the old one.
Finalize (Env);
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;
-- Now we can afford raising exceptions.
Set_Binds (Stack (Top).Data, Binds, Exprs);
end Replace_With_Sub;
procedure Replace_With_Sub (Env : in out Ptr;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
is
pragma Assert (Env.Index in 1 | Top);
begin
Replace_With_Sub (Env);
Set_Binds (Stack (Top).Data, Binds, Exprs);
end Replace_With_Sub;
procedure Set (Env : in Ptr;
Key : in Symbols.Ptr;
New_Element : in Mal.T)
is
pragma Assert (Env.Index in 1 | Top);
begin
Stack (Env.Index).Data.Include (Key, New_Element);
end Set;
procedure Set_Binds (M : in out HM.Map;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array)
function New_Env (Outer : in Ptr := null;
Binds : in Symbols.Symbol_Array := No_Binds;
Exprs : in Mal.T_Array := No_Exprs) return Ptr
is
use type Symbols.Ptr;
Varargs : constant Boolean := 1 < Binds'Length and then
Binds (Binds'Last - 1) = Symbols.Names.Ampersand;
Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with
Outer => Outer,
Data => HM.Empty_Map);
begin
Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length
else Exprs'Length = Binds'Length),
"actual parameters do not match formal parameters");
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop
M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I));
end loop;
if Varargs then
M.Include (Binds (Binds'Last), Sequences.List
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
if 2 <= Binds'Length
and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand
then
Err.Check (Binds'Length - 2 <= Exprs'Length,
"not enough actual parameters for vararg function");
for I in 0 .. Binds'Length - 3 loop
Ref.all.Data.Include (Key => Binds (Binds'First + I),
New_Item => Exprs (Exprs'First + I));
end loop;
Ref.all.Data.Include (Key => Binds (Binds'Last),
New_Item => Sequences.List
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
else
Err.Check (Binds'Length = Exprs'Length,
"wrong parameter count for (not vararg) function");
for I in 0 .. Binds'Length - 1 loop
Ref.all.Data.Include (Key => Binds (Binds'First + I),
New_Item => Exprs (Exprs'First + I));
end loop;
end if;
end Set_Binds;
return Ref;
end New_Env;
function Sub (Outer : in Ptr;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array) return Ptr
is
pragma Assert (Outer.Index in 1 | Top);
begin
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_Index => Outer.Index,
others => <>);
Set_Binds (Stack (Top).Data, Binds, Exprs);
return (Ada.Finalization.Limited_Controlled with Top);
end Sub;
function Sub (Outer : in Closure_Ptr'Class;
Binds : in Symbols.Symbol_Array;
Exprs : in Mal.T_Array) return Ptr
procedure Set (Env : in out Instance;
Key : in Symbols.Ptr;
New_Item : in Mal.T)
is
begin
Outer.Ref.all.Refs := @ + 1;
Top := Top + 1;
pragma Assert (Stack (Top).Data.Is_Empty);
pragma Assert (Stack (Top).Alias = null);
Stack (Top) := (Outer_On_Stack => False,
Outer_Ref => Outer.Ref,
others => <>);
-- Take care to construct the result before raising any
-- exception, so that it is finalized correctly.
return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top)
do
-- Now we can afford raising exceptions.
Set_Binds (Stack (Top).Data, Binds, Exprs);
end return;
end Sub;
procedure Unreference (Reference : in out Heap_Access) is
Ref : Heap_Access := Reference;
begin
Reference := null;
loop
exit when Ref = null;
exit when Ref.all.Refs = 0;
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
Tmp : Heap_Access := Ref;
begin
Ref := Ref.all.Outer;
Allocations := Allocations - 1;
Free (Tmp);
pragma Unreferenced (Tmp);
end;
end loop;
end Unreference;
Env.Data.Include (Key, New_Item);
end Set;
end Envs;

143
ada.2/envs.ads
View File

@ -1,138 +1,49 @@
private with Ada.Finalization;
private with Ada.Containers.Hashed_Maps;
with Garbage_Collected;
with Types.Mal;
with Types.Symbols;
package Envs with Elaborate_Body is
package Envs is
-- This package should be named Env, but Ada does not allow formal
-- parameters to be named like a package dependency, and it seems
-- that readability inside Eval is more important.
-- This implementation relies on the fact that the caller only
-- ever references environments in its execution stack.
type Instance (<>) is new Garbage_Collected.Instance with private;
type Ptr is access Instance;
-- When a function closure references an environment that the
-- execution leaves behind, a dynamically allocated block is used
-- instead.
No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array;
No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil);
-- The eval built-in requires REPL (see the implementation of
-- load-file), so we cannot assume that the caller only sees the
-- current environment.
function New_Env (Outer : in Ptr := null;
Binds : in Types.Symbols.Symbol_Array := No_Binds;
Exprs : in Types.Mal.T_Array := No_Exprs)
return Ptr;
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
-- * 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;
-- Allows assignment to a freshly created variable. This is
-- required for tail call optimization, but should be avoided
-- elsewhere.
procedure Replace_With_Sub (Env : in out Ptr) with Inline;
-- for let*
procedure Replace_With_Sub (Env : in out Ptr;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array) with Inline;
-- when expanding macros.
procedure Set (Env : in Ptr;
Key : in Types.Symbols.Ptr;
New_Element : in Types.Mal.T)
with Inline;
-- The Find method is merged into the Get method.
function Get (Evt : in Ptr;
function Get (Env : in Instance;
Key : in Types.Symbols.Ptr) return Types.Mal.T;
-- Raises Core.Error_Exception if the key is not found.
-- Function closures.
procedure Set (Env : in out Instance;
Key : in Types.Symbols.Ptr;
New_Item : in Types.Mal.T) with Inline;
type Closure_Ptr is tagged private;
Null_Closure : constant Closure_Ptr;
function New_Closure (Env : in Ptr'Class) return Closure_Ptr;
-- The class-wide argument does not make much sense, but avoids
-- the compiler wondering on which type is should dispatch.
function Sub (Outer : in Closure_Ptr'Class;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array) return Ptr;
-- when applying functions without tail call optimization.
-- Construct a new environment with the given outer parent.
-- Then call Set with the paired elements of Binds and Exprs,
-- handling the "&" special formal parameter if present.
-- May raise Error.
procedure Replace_With_Sub (Env : in out Ptr;
Outer : in Closure_Ptr'Class;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array);
-- when applying functions with tail call optimization.
-- Equivalent to Env := Sub (Env, Binds, Exprs), except that such
-- an assignment is forbidden or discouraged for performance reasons.
function Sub (Outer : in Ptr;
Binds : in Types.Symbols.Symbol_Array;
Exprs : in Types.Mal.T_Array) return Ptr;
-- when applying macros
-- Debugging.
procedure Dump_Stack (Long : in Boolean);
procedure Clear_And_Check_Allocations;
-- Debug.
procedure Dump_Stack (Env : in Instance);
private
-- 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.
package HM is new Ada.Containers.Hashed_Maps
(Key_Type => Types.Symbols.Ptr,
Element_Type => Types.Mal.T,
Hash => Types.Symbols.Hash,
Equivalent_Keys => Types.Symbols."=",
"=" => Types.Mal."=");
-- 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.
type Stack_Index is range 0 .. 200;
-- 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.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;
type Instance is new Garbage_Collected.Instance with record
Outer : Ptr;
Data : HM.Map;
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);
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Envs;

54
ada.2/garbage_collected.adb Normal file
View File

@ -0,0 +1,54 @@
with Ada.Unchecked_Deallocation;
package body Garbage_Collected is
procedure Free is new Ada.Unchecked_Deallocation (Class, Pointer);
Top : Pointer := null;
----------------------------------------------------------------------
procedure Clean is
Current : Pointer := Top;
Previous : Pointer;
begin
while Current /= null and then not Current.all.Kept loop
Previous := Current;
Current := Current.all.Next;
Free (Previous);
end loop;
Top := Current;
while Current /= null loop
if Current.all.Kept then
Current.all.Kept := False;
Previous := Current;
else
Previous.all.Next := Current.all.Next;
Free (Current);
end if;
Current := Previous.all.Next;
end loop;
end Clean;
procedure Keep (Object : in out Instance) is
begin
if not Object.Kept then
Object.Kept := True;
Class (Object).Keep_References; -- dispatching
end if;
end Keep;
procedure Check_Allocations is
begin
pragma Assert (Top = null);
end Check_Allocations;
procedure Register (Ref : in not null Pointer) is
begin
pragma Assert (Ref.all.Kept = False);
pragma Assert (Ref.all.Next = null);
Ref.all.Next := Top;
Top := Ref;
end Register;
end Garbage_Collected;

45
ada.2/garbage_collected.ads Normal file
View File

@ -0,0 +1,45 @@
package Garbage_Collected with Preelaborate is
-- A generic would not be convenient for lists. We want the
-- extended type to be able to have a discriminant.
-- However, we keep the dispatching in a single enumeration for
-- efficiency and clarity of the source.
type Instance is abstract tagged limited private;
subtype Class is Instance'Class;
type Pointer is access all Class;
procedure Keep_References (Object : in out Instance) is null with Inline;
-- A dispatching call in Keep allows subclasses to override this
-- in order to Keep each of the internal reference they maintain.
-- The following methods have no reason to be overridden.
procedure Keep (Object : in out Instance) with Inline;
-- Mark this object so that it is not deleted by next clean,
-- then make a dispatching call to Keep_References.
-- Does nothing if it has already been called for this object
-- since startup or last Clean.
procedure Register (Ref : in not null Pointer) with Inline;
-- Each subclass defines its own allocation pool, but every call
-- to new must be followed by a call to Register.
procedure Clean;
-- For each object for which Keep has not been called since
-- startup or last clean, make a dispatching call to Finalize,
-- then deallocate the memory for the object.
-- Debug.
procedure Check_Allocations with Inline;
-- Does nothing if assertions are disabled.
private
type Instance is abstract tagged limited record
Kept : Boolean := False;
Next : Pointer := null;
end record;
end Garbage_Collected;

28
ada.2/printer.adb
View File

@ -22,10 +22,10 @@ package body Printer is
-- Helpers for Print_Form.
procedure Print_Number (Number : in Integer) with Inline;
procedure Print_List (List : in Sequences.Ptr) with Inline;
procedure Print_Map (Map : in Maps.Ptr) with Inline;
procedure Print_List (List : in Sequences.Instance) with Inline;
procedure Print_Map (Map : in Maps.Instance) with Inline;
procedure Print_Readably (S : in Unbounded_String) with Inline;
procedure Print_Function (Fn : in Fns.Ptr) with Inline;
procedure Print_Function (Fn : in Fns.Instance) with Inline;
----------------------------------------------------------------------
@ -41,7 +41,7 @@ package body Printer is
Append (Buffer, "false");
end if;
when Kind_Symbol =>
Append (Buffer, Form_Ast.Symbol.To_String);
Append (Buffer, Symbols.To_String (Form_Ast.Symbol));
when Kind_Number =>
Print_Number (Form_Ast.Number);
when Kind_Keyword =>
@ -57,34 +57,34 @@ package body Printer is
end if;
when Kind_List =>
Append (Buffer, '(');
Print_List (Form_Ast.Sequence);
Print_List (Form_Ast.Sequence.all);
Append (Buffer, ')');
when Kind_Vector =>
Append (Buffer, '[');
Print_List (Form_Ast.Sequence);
Print_List (Form_Ast.Sequence.all);
Append (Buffer, ']');
when Kind_Map =>
Append (Buffer, '{');
Print_Map (Form_Ast.Map);
Print_Map (Form_Ast.Map.all);
Append (Buffer, '}');
when Kind_Builtin | Kind_Builtin_With_Meta =>
Append (Buffer, "#<built-in>");
when Kind_Fn =>
Append (Buffer, "#<function (");
Print_Function (Form_Ast.Fn);
Print_Function (Form_Ast.Fn.all);
Append (Buffer, '>');
when Kind_Macro =>
Append (Buffer, "#<macro (");
Print_Function (Form_Ast.Fn);
Print_Function (Form_Ast.Fn.all);
Append (Buffer, '>');
when Kind_Atom =>
Append (Buffer, "(atom ");
Print_Form (Atoms.Deref (Form_Ast.Atom));
Print_Form (Form_Ast.Atom.all.Deref);
Append (Buffer, ')');
end case;
end Print_Form;
procedure Print_Function (Fn : in Fns.Ptr) is
procedure Print_Function (Fn : in Fns.Instance) is
Started : Boolean := False;
begin
Append (Buffer, '(');
@ -94,13 +94,13 @@ package body Printer is
else
Started := True;
end if;
Append (Buffer, Param.To_String);
Append (Buffer, Symbols.To_String (Param));
end loop;
Append (Buffer, ") -> ");
Print_Form (Fn.Ast);
end Print_Function;
procedure Print_List (List : in Sequences.Ptr) is
procedure Print_List (List : in Sequences.Instance) is
begin
if 0 < List.Length then
Print_Form (List (1));
@ -111,7 +111,7 @@ package body Printer is
end if;
end Print_List;
procedure Print_Map (Map : in Maps.Ptr) is
procedure Print_Map (Map : in Maps.Instance) is
procedure Process (Key : in Mal.T;
Element : in Mal.T) with Inline;
procedure Iterate is new Maps.Iterate (Process);

129
ada.2/reader.adb
View File

@ -13,7 +13,7 @@ with Types.Symbols.Names;
package body Reader is
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader");
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread");
use Types;
use type Ada.Strings.Maps.Character_Set;
@ -37,7 +37,7 @@ package body Reader is
B_Last : Natural := Buffer'First - 1;
-- Index in Buffer of the currently written MAL expression.
procedure Read_Form;
function Read_Form return Mal.T;
-- The recursive part of Read_Str.
-- Helpers for Read_Form:
@ -58,124 +58,127 @@ package body Reader is
-- Read_Atom has been merged into the same case/switch
-- statement, for clarity and efficiency.
procedure Read_List (Ending : in Character;
Constructor : in not null Mal.Builtin_Ptr)
with Inline;
procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline;
procedure Read_String with Inline;
procedure Read_With_Meta with Inline;
function Read_List (Ending : in Character) return Natural with Inline;
-- Returns the index of the last elements in Buffer.
-- The elements have been stored in Buffer (B_Last .. result).
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline;
function Read_String return Mal.T with Inline;
function Read_With_Meta return Mal.T with Inline;
----------------------------------------------------------------------
procedure Read_List (Ending : in Character;
Constructor : in not null Mal.Builtin_Ptr) is
function Read_List (Ending : in Character) return Natural is
Opening : constant Character := Source (I);
B_First : constant Positive := B_Last;
Old : constant Natural := B_Last;
Result : Positive;
begin
I := I + 1; -- Skip (, [ or {.
loop
Skip_Ignored;
Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'");
exit when Source (I) = Ending;
Read_Form;
B_Last := B_Last + 1;
Buffer (B_Last) := Read_Form;
end loop;
I := I + 1; -- Skip ), ] or }.
Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1));
B_Last := B_First;
Result := B_Last;
B_Last := Old;
return Result;
end Read_List;
procedure Read_Quote (Symbol : in Symbols.Ptr) is
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is
R : constant Mal.Sequence_Ptr := Sequences.Constructor (2);
begin
Buffer (B_Last) := (Kind_Symbol, Symbol);
I := I + 1; -- Skip the initial ' or similar.
R.Replace_Element (1, (Kind_Symbol, Symbol));
Skip_Ignored;
Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'");
B_Last := B_Last + 1;
Read_Form;
B_Last := B_Last - 1;
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1));
Err.Check (I <= Source'Last,
"Incomplete '" & Symbols.To_String (Symbol) & "'");
R.Replace_Element (2, Read_Form);
return (Kind_List, R);
end Read_Quote;
procedure Read_Form is
function Read_Form return Mal.T is
-- After I has been increased, current token is be
-- Source (F .. I - 1).
F : Positive;
R : Mal.T; -- The result of this function.
begin
case Source (I) is
when ')' | ']' | '}' =>
Err.Raise_With ("unbalanced '" & Source (I) & "'");
when '"' =>
Read_String;
R := Read_String;
when ':' =>
I := I + 1;
F := I;
Skip_Symbol;
Buffer (B_Last) := (Kind_Keyword,
Ada.Strings.Unbounded.To_Unbounded_String
(Source (F .. I - 1)));
R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String
(Source (F .. I - 1)));
when '-' =>
F := I;
Skip_Digits;
if F + 1 < I then
Buffer (B_Last) := (Kind_Number,
Integer'Value (Source (F .. I - 1)));
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
else
Skip_Symbol;
Buffer (B_Last) := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
end if;
when '~' =>
if I < Source'Last and then Source (I + 1) = '@' then
I := I + 1;
Read_Quote (Symbols.Names.Splice_Unquote);
R := Read_Quote (Symbols.Names.Splice_Unquote);
else
Read_Quote (Symbols.Names.Unquote);
R := Read_Quote (Symbols.Names.Unquote);
end if;
when '0' .. '9' =>
F := I;
Skip_Digits;
Buffer (B_Last) := (Kind_Number,
Integer'Value (Source (F .. I - 1)));
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
when ''' =>
Read_Quote (Symbols.Names.Quote);
R := Read_Quote (Symbols.Names.Quote);
when '`' =>
Read_Quote (Symbols.Names.Quasiquote);
R := Read_Quote (Symbols.Names.Quasiquote);
when '@' =>
Read_Quote (Symbols.Names.Deref);
R := Read_Quote (Symbols.Names.Deref);
when '^' =>
Read_With_Meta;
R := Read_With_Meta;
when '(' =>
Read_List (')', Sequences.List'Access);
R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')')));
when '[' =>
Read_List (']', Sequences.Vector'Access);
R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']')));
when '{' =>
Read_List ('}', Maps.Hash_Map'Access);
R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}')));
when others =>
F := I;
Skip_Symbol;
if Source (F .. I - 1) = "false" then
Buffer (B_Last) := (Kind_Boolean, False);
R := (Kind_Boolean, False);
elsif Source (F .. I - 1) = "nil" then
Buffer (B_Last) := Mal.Nil;
R := Mal.Nil;
elsif Source (F .. I - 1) = "true" then
Buffer (B_Last) := (Kind_Boolean, True);
R := (Kind_Boolean, True);
else
Buffer (B_Last) := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
end if;
end case;
if Debug then
Ada.Text_IO.Put ("reader: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer
(B_Last)));
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R));
end if;
return R;
end Read_Form;
procedure Read_String is
function Read_String return Mal.T is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin
Buffer (B_Last) := (Kind_String, Null_Unbounded_String);
loop
I := I + 1;
Err.Check (I <= Source'Last, "unbalanced '""'");
@ -187,33 +190,31 @@ package body Reader is
Err.Check (I <= Source'Last, "unbalanced '""'");
case Source (I) is
when '\' | '"' =>
Append (Buffer (B_Last).S, Source (I));
Append (Result, Source (I));
when 'n' =>
Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF);
Append (Result, Ada.Characters.Latin_1.LF);
when others =>
Append (Buffer (B_Last).S, Source (I - 1 .. I));
Append (Result, Source (I - 1 .. I));
end case;
when others =>
Append (Buffer (B_Last).S, Source (I));
Append (Result, Source (I));
end case;
end loop;
I := I + 1; -- Skip closing double quote.
return (Kind_String, Result);
end Read_String;
procedure Read_With_Meta is
function Read_With_Meta return Mal.T is
List : constant Mal.Sequence_Ptr := Sequences.Constructor (3);
begin
I := I + 1; -- Skip the initial ^.
for Argument in 1 .. 2 loop
List.all.Replace_Element (1, (Kind_Symbol, Symbols.Names.With_Meta));
for I in reverse 2 .. 3 loop
Skip_Ignored;
Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
Read_Form;
B_Last := B_Last + 1;
List.all.Replace_Element (I, Read_Form);
end loop;
-- Replace (metadata data) with (with-meta data metadata).
B_Last := B_Last - 2;
Buffer (B_Last + 2) := Buffer (B_Last);
Buffer (B_Last) := (Kind_Symbol, Symbols.Names.With_Meta);
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 2));
return (Kind_List, List);
end Read_With_Meta;
procedure Skip_Digits is
@ -259,7 +260,7 @@ package body Reader is
Skip_Ignored;
exit when Source'Last < I;
B_Last := B_Last + 1;
Read_Form;
Buffer (B_Last) := Read_Form;
end loop;
return Buffer (Buffer'First .. B_Last);
end Read_Str;

20
ada.2/step1_read_print.adb
View File

@ -1,15 +1,11 @@
with Ada.Text_IO.Unbounded_IO;
with Err;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols;
procedure Step1_Read_Print is
@ -56,14 +52,14 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step1_Read_Print;

46
ada.2/step2_eval.adb
View File

@ -4,12 +4,10 @@ with Ada.Strings.Hash;
with Ada.Text_IO.Unbounded_IO;
with Err;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
@ -41,7 +39,6 @@ procedure Step2_Eval is
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Map, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
----------------------------------------------------------------------
@ -56,6 +53,7 @@ procedure Step2_Eval is
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -70,29 +68,40 @@ procedure Step2_Eval is
return (Kind_Builtin, Envs.Element (C));
end;
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Eval (Ast.Sequence (1), Env);
First := Ast.Sequence.all (1);
-- Ast is a non-empty list, First is its first element.
First := Eval (First, Env);
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
-- First is its evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
@ -147,14 +156,15 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step2_Eval;

107
ada.2/step3_env.adb
View File

@ -3,12 +3,10 @@ with Ada.Text_IO.Unbounded_IO;
with Envs;
with Err;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
@ -16,11 +14,7 @@ with Types.Symbols.Names;
procedure Step3_Env is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
@ -37,7 +31,6 @@ procedure Step3_Env is
with function Ada_Operator (Left, Right : in Integer) return Integer;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
----------------------------------------------------------------------
@ -52,60 +45,67 @@ procedure Step3_Env is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
-- This curious syntax is useful for later steps.
New_Env : Envs.Ptr := Env.Copy_Pointer;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
New_Env : Envs.Ptr;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
New_Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
New_Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
New_Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), New_Env));
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), New_Env));
end loop;
return Eval (Ast.Sequence (3), New_Env);
return Eval (Ast.Sequence.all (3), New_Env);
end;
else
First := Eval (First, Env);
@ -120,10 +120,10 @@ procedure Step3_Env is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
@ -162,16 +162,18 @@ procedure Step3_Env is
function Product is new Generic_Mal_Operator ("*");
function Division is new Generic_Mal_Operator ("/");
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
begin
Repl.Set (Symbols.Constructor ("+"),
(Kind_Builtin, Addition 'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("-"),
(Kind_Builtin, Subtraction'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("*"),
(Kind_Builtin, Product 'Unrestricted_Access));
Repl.Set (Symbols.Constructor ("/"),
(Kind_Builtin, Division 'Unrestricted_Access));
-- Add Core functions into the top environment.
Repl.all.Set (Symbols.Constructor ("+"),
(Kind_Builtin, Addition 'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("-"),
(Kind_Builtin, Subtraction'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("*"),
(Kind_Builtin, Product 'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("/"),
(Kind_Builtin, Division 'Unrestricted_Access));
-- Execute user commands.
loop
begin
Rep (Repl);
@ -182,15 +184,16 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step3_Env;

118
ada.2/step4_if_fn_do.adb
View File

@ -5,11 +5,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -18,11 +17,7 @@ with Types.Symbols.Names;
procedure Step4_If_Fn_Do is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
@ -36,7 +31,6 @@ procedure Step4_If_Fn_Do is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -55,82 +49,90 @@ procedure Step4_If_Fn_Do is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
return Eval (Ast.Sequence (3), Env);
elsif Ast.Sequence.Length = 3 then
return Eval (Ast.Sequence.all (3), Env);
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
return Eval (Ast.Sequence (4), Env);
return Eval (Ast.Sequence.all (4), Env);
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
-- This curious syntax is useful for later steps.
New_Env : Envs.Ptr := Env.Copy_Pointer;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
New_Env : Envs.Ptr;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
New_Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
New_Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
New_Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), New_Env));
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), New_Env));
end loop;
return Eval (Ast.Sequence (3), New_Env);
return Eval (Ast.Sequence.all (3), New_Env);
end;
else
First := Eval (First, Env);
@ -145,21 +147,21 @@ procedure Step4_If_Fn_Do is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Fn.Apply (Args);
return First.Fn.all.Apply (Args);
end;
when others =>
Err.Raise_With ("first element must be a function");
@ -200,14 +202,15 @@ procedure Step4_If_Fn_Do is
Startup : constant String
:= "(def! not (fn* (a) (if a false true)))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
-- Native startup procedure.
Exec (Startup, Repl);
-- Execute user commands.
loop
begin
Rep (Repl);
@ -218,15 +221,16 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step4_If_Fn_Do;

125
ada.2/step5_tco.adb
View File

@ -5,11 +5,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -18,11 +17,7 @@ with Types.Symbols.Names;
procedure Step5_Tco is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
@ -36,7 +31,6 @@ procedure Step5_Tco is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -52,7 +46,7 @@ procedure Step5_Tco is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
First : Mal.T;
begin
<<Restart>>
@ -60,88 +54,97 @@ procedure Step5_Tco is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -160,24 +163,24 @@ procedure Step5_Tco is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
@ -219,14 +222,15 @@ procedure Step5_Tco is
Startup : constant String
:= "(def! not (fn* (a) (if a false true)))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
-- Native startup procedure.
Exec (Startup, Repl);
-- Execute user commands.
loop
begin
Rep (Repl);
@ -237,15 +241,16 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step5_Tco;

159
ada.2/step6_file.adb
View File

@ -7,11 +7,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -20,26 +19,24 @@ with Types.Symbols.Names;
procedure Step6_File is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
-- The built-in variant needs to see the Repl variable.
procedure Print (Ast : in Mal.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -55,7 +52,7 @@ procedure Step6_File is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
First : Mal.T;
begin
<<Restart>>
@ -63,88 +60,97 @@ procedure Step6_File is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -163,24 +169,24 @@ procedure Step6_File is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
@ -224,27 +230,37 @@ procedure Step6_File is
:= "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
declare
use Ada.Command_Line;
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
end;
-- Script?
if 0 < Ada.Command_Line.Argument_Count then
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
else
loop
begin
@ -256,16 +272,17 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
end if;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step6_File;

220
ada.2/step7_quote.adb
View File

@ -1,4 +1,5 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
@ -7,11 +8,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -20,20 +20,19 @@ with Types.Symbols.Names;
procedure Step7_Quote is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
@ -46,7 +45,6 @@ procedure Step7_Quote is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -62,7 +60,7 @@ procedure Step7_Quote is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
First : Mal.T;
begin
<<Restart>>
@ -70,94 +68,103 @@ procedure Step7_Quote is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Quasiquote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Ast.Sequence (2);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -176,24 +183,24 @@ procedure Step7_Quote is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
@ -225,46 +232,56 @@ procedure Step7_Quote is
Env : in Envs.Ptr) return Mal.T
is
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
begin
for I in R'Range loop
R (I) := List (I);
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
and then R (I).Sequence (1) = (Kind_Symbol,
Symbols.Names.Splice_Unquote)
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
then
Err.Check (R (I).Sequence.Length = 2,
Err.Check (List (I).Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
R (I) := Eval (@.Sequence (2), Env);
Err.Check (R (I).Kind = Kind_List,
Tmp := Eval (List (I).Sequence.all (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
end loop;
else
R (I) := Sequences.List
(Mal.T_Array'(1 => Quasiquote (@, Env)));
Vector.Append (Quasiquote (List (I), Env));
end if;
end loop;
return Sequences.Concat (R);
-- Now that we know the number of elements, convert to a list.
Sequence := Sequences.Constructor (Natural (Vector.Length));
for I in 1 .. Natural (Vector.Length) loop
Sequence.Replace_Element (I, Vector (I));
end loop;
return (Kind_List, Sequence);
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
when Kind_List =>
if 0 < Ast.Sequence.Length
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
else
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
end if;
when others =>
return Ast;
@ -291,27 +308,37 @@ procedure Step7_Quote is
:= "(def! not (fn* (a) (if a false true)))"
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
declare
use Ada.Command_Line;
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
end;
-- Script?
if 0 < Ada.Command_Line.Argument_Count then
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
else
loop
begin
@ -323,16 +350,17 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
end if;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step7_Quote;

251
ada.2/step8_macros.adb
View File

@ -1,4 +1,5 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
@ -7,11 +8,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -20,20 +20,19 @@ with Types.Symbols.Names;
procedure Step8_Macros is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
@ -46,7 +45,6 @@ procedure Step8_Macros is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -62,7 +60,7 @@ procedure Step8_Macros is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
@ -71,111 +69,120 @@ procedure Step8_Macros is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence (2);
Ast := Ast.Sequence.all (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Ast.Sequence (2);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -194,43 +201,44 @@ procedure Step8_Macros is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env.Replace_With_Sub (Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.Ast, Envs.Sub
(Outer => Env,
Binds => First.Fn.Params,
Exprs => Args));
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
@ -268,46 +276,56 @@ procedure Step8_Macros is
Env : in Envs.Ptr) return Mal.T
is
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
begin
for I in R'Range loop
R (I) := List (I);
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
and then R (I).Sequence (1) = (Kind_Symbol,
Symbols.Names.Splice_Unquote)
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
then
Err.Check (R (I).Sequence.Length = 2,
Err.Check (List (I).Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
R (I) := Eval (@.Sequence (2), Env);
Err.Check (R (I).Kind = Kind_List,
Tmp := Eval (List (I).Sequence.all (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
end loop;
else
R (I) := Sequences.List
(Mal.T_Array'(1 => Quasiquote (@, Env)));
Vector.Append (Quasiquote (List (I), Env));
end if;
end loop;
return Sequences.Concat (R);
-- Now that we know the number of elements, convert to a list.
Sequence := Sequences.Constructor (Natural (Vector.Length));
for I in 1 .. Natural (Vector.Length) loop
Sequence.Replace_Element (I, Vector (I));
end loop;
return (Kind_List, Sequence);
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
when Kind_List =>
if 0 < Ast.Sequence.Length
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
else
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
end if;
when others =>
return Ast;
@ -345,27 +363,37 @@ procedure Step8_Macros is
& " (if (= 1 (count xs)) (first xs)"
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
declare
use Ada.Command_Line;
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
end;
-- Script?
if 0 < Ada.Command_Line.Argument_Count then
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
else
loop
begin
@ -377,16 +405,17 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
end if;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step8_Macros;

282
ada.2/step9_try.adb
View File

@ -1,4 +1,5 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
@ -7,11 +8,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
@ -20,20 +20,19 @@ with Types.Symbols.Names;
procedure Step9_Try is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
@ -46,7 +45,6 @@ procedure Step9_Try is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -62,7 +60,7 @@ procedure Step9_Try is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
@ -71,137 +69,149 @@ procedure Step9_Try is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence (2);
Ast := Ast.Sequence.all (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Ast.Sequence (2);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.Sequence.Length = 2 then
Ast := Ast.Sequence (2);
if Ast.Sequence.all.Length = 2 then
Ast := Ast.Sequence.all (2);
goto Restart;
end if;
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
Err.Check (Ast.Sequence (3).Kind = Kind_List,
Err.Check (Ast.Sequence.all.Length = 3,
"expected 1 or 2 parameters");
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
"parameter 2 must be a list");
declare
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
begin
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
Err.Check (A3.all.Length = 3,
"length of parameter 2 must be 3");
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
"parameter 3 must start with 'catch*'");
Err.Check (A3 (2).Kind = Kind_Symbol,
Err.Check (A3.all (2).Kind = Kind_Symbol,
"a symbol must follow catch*");
begin
return Eval (Ast.Sequence (2), Env);
return Eval (Ast.Sequence.all (2), Env);
exception
when Err.Error =>
Env.Replace_With_Sub;
Env.Set (A3 (2).Symbol, Err.Data);
Ast := A3 (3);
goto Restart;
when Err.Error =>
null;
end;
Env := Envs.New_Env (Outer => Env);
Env.all.Set (A3.all (2).Symbol, Err.Data);
Ast := A3.all (3);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -220,43 +230,44 @@ procedure Step9_Try is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env.Replace_With_Sub (Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.Ast, Envs.Sub
(Outer => Env,
Binds => First.Fn.Params,
Exprs => Args));
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
@ -294,46 +305,56 @@ procedure Step9_Try is
Env : in Envs.Ptr) return Mal.T
is
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
begin
for I in R'Range loop
R (I) := List (I);
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
and then R (I).Sequence (1) = (Kind_Symbol,
Symbols.Names.Splice_Unquote)
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
then
Err.Check (R (I).Sequence.Length = 2,
Err.Check (List (I).Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
R (I) := Eval (@.Sequence (2), Env);
Err.Check (R (I).Kind = Kind_List,
Tmp := Eval (List (I).Sequence.all (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
end loop;
else
R (I) := Sequences.List
(Mal.T_Array'(1 => Quasiquote (@, Env)));
Vector.Append (Quasiquote (List (I), Env));
end if;
end loop;
return Sequences.Concat (R);
-- Now that we know the number of elements, convert to a list.
Sequence := Sequences.Constructor (Natural (Vector.Length));
for I in 1 .. Natural (Vector.Length) loop
Sequence.Replace_Element (I, Vector (I));
end loop;
return (Kind_List, Sequence);
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
when Kind_List =>
if 0 < Ast.Sequence.Length
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
else
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
end if;
when others =>
return Ast;
@ -371,27 +392,37 @@ procedure Step9_Try is
& " (if (= 1 (count xs)) (first xs)"
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
declare
use Ada.Command_Line;
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
end;
-- Script?
if 0 < Ada.Command_Line.Argument_Count then
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
else
loop
begin
@ -403,16 +434,17 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
end if;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step9_Try;

287
ada.2/stepa_mal.adb
View File

@ -1,4 +1,5 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
@ -7,10 +8,10 @@ with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
@ -20,20 +21,19 @@ with Types.Symbols.Names;
procedure StepA_Mal is
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
Dbgenv0 : constant Boolean
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
Dbgeval : constant Boolean
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
@ -46,7 +46,6 @@ procedure StepA_Mal is
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
procedure Exec (Script : in String;
@ -62,7 +61,7 @@ procedure StepA_Mal is
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Env : Envs.Ptr := Env0.Copy_Pointer;
Env : Envs.Ptr := Env0;
Macroexpanding : Boolean := False;
First : Mal.T;
begin
@ -71,137 +70,149 @@ procedure StepA_Mal is
Ada.Text_IO.New_Line;
Ada.Text_IO.Put ("EVAL: ");
Print (Ast);
if Dbgenv0 then
Envs.Dump_Stack (Long => Dbgenv1);
end if;
Envs.Dump_Stack (Env.all);
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.Get (Ast.Symbol);
return Env.all.Get (Ast.Symbol);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map, Env);
return Eval_Map_Elts (Ast.Map.all, Env);
when Kind_Vector =>
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
declare
Len : constant Natural := Ast.Sequence.all.Length;
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
begin
for I in 1 .. Len loop
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
end loop;
return (Kind_Vector, List);
end;
when Kind_List =>
null;
end case;
-- Ast is a list.
if Ast.Sequence.Length = 0 then
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence (1);
First := Ast.Sequence.all (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.New_Macro do
Env.Set (Ast.Sequence (2).Symbol, R);
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
Ast => Ast.Sequence (3),
Env => Env.New_Closure);
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
Err.Check (Ast.Sequence.Length in 3 .. 4,
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
elsif Ast.Sequence.Length = 3 then
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
else
Ast := Ast.Sequence (4);
Ast := Ast.Sequence.all (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
declare
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
begin
Err.Check (Bindings.Length mod 2 = 0,
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env.Replace_With_Sub;
for I in 1 .. Bindings.Length / 2 loop
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.Set (Bindings (2 * I - 1).Symbol,
Eval (Bindings (2 * I), Env));
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
end loop;
Ast := Ast.Sequence (3);
Ast := Ast.Sequence.all (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence (2);
Ast := Ast.Sequence.all (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Ast.Sequence (2);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
elsif First.Symbol = Symbols.Names.Try then
if Ast.Sequence.Length = 2 then
Ast := Ast.Sequence (2);
if Ast.Sequence.all.Length = 2 then
Ast := Ast.Sequence.all (2);
goto Restart;
end if;
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
Err.Check (Ast.Sequence (3).Kind = Kind_List,
Err.Check (Ast.Sequence.all.Length = 3,
"expected 1 or 2 parameters");
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
"parameter 2 must be a list");
declare
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
begin
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
Err.Check (A3.all.Length = 3,
"length of parameter 2 must be 3");
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
"parameter 3 must start with 'catch*'");
Err.Check (A3 (2).Kind = Kind_Symbol,
Err.Check (A3.all (2).Kind = Kind_Symbol,
"a symbol must follow catch*");
begin
return Eval (Ast.Sequence (2), Env);
return Eval (Ast.Sequence.all (2), Env);
exception
when Err.Error =>
Env.Replace_With_Sub;
Env.Set (A3 (2).Symbol, Err.Data);
Ast := A3 (3);
goto Restart;
when Err.Error =>
null;
end;
Env := Envs.New_Env (Outer => Env);
Env.all.Set (A3.all (2).Symbol, Err.Data);
Ast := A3.all (3);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.Get (First.Symbol);
First := Env.all.Get (First.Symbol);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
@ -220,52 +231,53 @@ procedure StepA_Mal is
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Builtin_With_Meta =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin_With_Meta.Builtin.all (Args);
return First.Builtin_With_Meta.all.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence (I), Env);
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env.Replace_With_Sub (Outer => First.Fn.Env,
Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env.Replace_With_Sub (Binds => First.Fn.Params,
Exprs => Args);
Ast := First.Fn.Ast;
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.Ast, Envs.Sub
(Outer => Env,
Binds => First.Fn.Params,
Exprs => Args));
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
@ -303,46 +315,56 @@ procedure StepA_Mal is
Env : in Envs.Ptr) return Mal.T
is
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
-- The final return concatenates these lists.
R : Mal.T_Array (1 .. List.Length);
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
begin
for I in R'Range loop
R (I) := List (I);
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
and then R (I).Sequence (1) = (Kind_Symbol,
Symbols.Names.Splice_Unquote)
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
then
Err.Check (R (I).Sequence.Length = 2,
Err.Check (List (I).Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
R (I) := Eval (@.Sequence (2), Env);
Err.Check (R (I).Kind = Kind_List,
Tmp := Eval (List (I).Sequence.all (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
end loop;
else
R (I) := Sequences.List
(Mal.T_Array'(1 => Quasiquote (@, Env)));
Vector.Append (Quasiquote (List (I), Env));
end if;
end loop;
return Sequences.Concat (R);
-- Now that we know the number of elements, convert to a list.
Sequence := Sequences.Constructor (Natural (Vector.Length));
for I in 1 .. Natural (Vector.Length) loop
Sequence.Replace_Element (I, Vector (I));
end loop;
return (Kind_List, Sequence);
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
when Kind_List =>
if 0 < Ast.Sequence.Length
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
then
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence (2), Env);
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
else
return Quasiquote_List (Ast.Sequence);
return Quasiquote_List (Ast.Sequence.all);
end if;
when others =>
return Ast;
@ -385,27 +407,37 @@ procedure StepA_Mal is
& " `(let* (~condvar ~(first xs))"
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
& "(def! *host-language* ""ada.2"")";
Repl : Envs.Ptr renames Envs.Repl;
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl;
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
declare
use Ada.Command_Line;
Args : Mal.T_Array (2 .. Argument_Count);
begin
for I in Args'Range loop
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
end;
-- Script?
if 0 < Ada.Command_Line.Argument_Count then
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
else
Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl);
loop
@ -418,16 +450,17 @@ begin
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
end;
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
end if;
-- If assertions are enabled, check deallocations.
Err.Data := Mal.Nil; -- Remove references to other packages
pragma Debug (Envs.Clear_And_Check_Allocations);
pragma Debug (Atoms.Check_Allocations);
pragma Debug (Builtins.Check_Allocations);
pragma Debug (Fns.Check_Allocations);
pragma Debug (Maps.Check_Allocations);
pragma Debug (Sequences.Check_Allocations);
pragma Debug (Symbols.Check_Allocations);
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end StepA_Mal;

65
ada.2/types-atoms.adb
View File

@ -1,68 +1,41 @@
with Ada.Unchecked_Deallocation;
with Err;
with Types.Mal;
with Types.Builtins;
with Types.Fns;
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);
Allocations : Natural := 0;
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := @ + 1;
end Adjust;
function Atom (Args : in Mal.T_Array) return Mal.T is
Ref : Mal.Atom_Ptr;
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Allocations := Allocations + 1;
return (Kind_Atom, (Ada.Finalization.Controlled with new Rec'
(Refs => 1,
Data => Args (Args'First))));
Ref := new Instance'(Garbage_Collected.Instance with
Data => Args (Args'First));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Atom, Ref);
end Atom;
procedure Check_Allocations is
begin
pragma Assert (Allocations = 0);
end Check_Allocations;
function Deref (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom");
return Args (Args'First).Atom.Ref.all.Data;
return Args (Args'First).Atom.all.Data;
end Deref;
function Deref (Item : in Ptr) return Mal.T
is (Item.Ref.all.Data);
function Deref (Item : in Instance) return Mal.T
is (Item.Data);
procedure Finalize (Object : in out Ptr) is
procedure Keep_References (Object : in out Instance) is
begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
Object.Ref.all.Refs := @ - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
end if;
end Finalize;
Mal.Keep (Object.Data);
end Keep_References;
function Reset (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Atom,
"parameter 1 must be an atom");
Args (Args'First).Atom.Ref.all.Data := Args (Args'Last);
"parameter 1 must be an atom");
Args (Args'First).Atom.all.Data := Args (Args'Last);
return Args (Args'Last);
end Reset;
@ -73,7 +46,7 @@ package body Types.Atoms is
"parameter 1 must be an atom");
declare
use type Mal.T_Array;
X : Mal.T renames Args (Args'First).Atom.Ref.all.Data;
X : Mal.T renames Args (Args'First).Atom.all.Data;
F : Mal.T renames Args (Args'First + 1);
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
begin
@ -81,9 +54,9 @@ package body Types.Atoms is
when Kind_Builtin =>
X := F.Builtin.all (A);
when Kind_Builtin_With_Meta =>
X := F.Builtin_With_Meta.Builtin.all (A);
X := F.Builtin_With_Meta.all.Builtin.all (A);
when Kind_Fn =>
X := F.Fn.Apply (A);
X := F.Fn.all.Apply (A);
when others =>
Err.Raise_With ("parameter 2 must be a function");
end case;

25
ada.2/types-atoms.ads
View File

@ -1,10 +1,9 @@
private with Ada.Finalization;
limited with Types.Mal;
with Garbage_Collected;
with Types.Mal;
package Types.Atoms is
type Ptr is private;
type Instance (<>) is new Garbage_Collected.Instance with private;
-- Built-in functions.
function Atom (Args : in Mal.T_Array) return Mal.T;
@ -13,21 +12,13 @@ package Types.Atoms is
function Swap (Args : in Mal.T_Array) return Mal.T;
-- Helper for print.
function Deref (Item : in Ptr) return Mal.T with Inline;
-- Debug.
procedure Check_Allocations;
function Deref (Item : in Instance) return Mal.T with Inline;
private
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Acc := null;
end record
with Invariant => Ptr.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);
type Instance is new Garbage_Collected.Instance with record
Data : Mal.T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Atoms;

67
ada.2/types-builtins.adb
View File

@ -1,63 +1,30 @@
with Ada.Unchecked_Deallocation;
with Types.Mal;
package body Types.Builtins is
type Rec is limited record
Builtin : Mal.Builtin_Ptr;
Refs : Natural;
Meta : Mal.T;
end record;
function Builtin (Item : in Instance) return Mal.Builtin_Ptr
is (Item.F_Builtin);
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
Allocations : Natural := 0;
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
procedure Keep_References (Object : in out Instance) is
begin
Object.Ref.all.Refs := @ + 1;
end Adjust;
Mal.Keep (Object.F_Meta);
end Keep_References;
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr
is (Item.Ref.all.Builtin);
procedure Check_Allocations is
begin
pragma Assert (Allocations = 0);
end Check_Allocations;
procedure Finalize (Object : in out Ptr) is
begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
Object.Ref.all.Refs := @ - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
end if;
end Finalize;
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function Meta (Item : in Instance) return Mal.T
is (Item.F_Meta);
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T is
Metadata : in Mal.T) return Mal.T
is
Ref : constant Mal.Builtin_With_Meta_Ptr
:= new Instance'(Garbage_Collected.Instance with
F_Builtin => Builtin,
F_Meta => Metadata);
begin
Allocations := Allocations + 1;
return (Kind_Builtin_With_Meta,
(Ada.Finalization.Controlled with new Rec'(Builtin => Builtin,
Meta => Metadata,
Refs => 1)));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Builtin_With_Meta, Ref);
end With_Meta;
function With_Meta (Item : in Ptr;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T
-- Do not try to reuse the memory. We can hope that this kind of
-- nonsense will be rare.
is (With_Meta (Item.Ref.all.Builtin, Metadata));
is (With_Meta (Item.Builtin, Metadata));
end Types.Builtins;

29
ada.2/types-builtins.ads
View File

@ -1,6 +1,5 @@
private with Ada.Finalization;
limited with Types.Mal;
with Garbage_Collected;
with Types.Mal;
package Types.Builtins is
@ -9,27 +8,21 @@ package Types.Builtins is
-- functions. The controlled type below is only useful when one
-- has the silly idea to add metadata to a built-in.
type Ptr is tagged private;
type Instance is new Garbage_Collected.Instance with private;
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T with Inline;
function With_Meta (Item : in Ptr;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T with Inline;
function Meta (Item : in Ptr) return Mal.T with Inline;
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline;
procedure Check_Allocations;
function Meta (Item : in Instance) return Mal.T with Inline;
function Builtin (Item : in Instance) return Mal.Builtin_Ptr with Inline;
private
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Acc := null;
end record
with Invariant => Ptr.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);
type Instance is new Garbage_Collected.Instance with record
F_Builtin : Mal.Builtin_Ptr;
F_Meta : Mal.T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Builtins;

170
ada.2/types-fns.adb
View File

@ -1,144 +1,86 @@
with Ada.Unchecked_Deallocation;
with Envs;
with Err;
with Eval_Cb;
with Types.Mal;
with Types.Sequences;
with Types.Symbols;
package body Types.Fns is
subtype AFC is Ada.Finalization.Controlled;
use type Envs.Closure_Ptr;
type Rec (Params_Last : Natural) is limited record
Ast : Mal.T;
Refs : Natural := 1;
Env : Envs.Closure_Ptr := Envs.Null_Closure;
Meta : Mal.T := Mal.Nil;
Params : Symbols.Symbol_Array (1 .. Params_Last);
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
Allocations : Natural := 0;
use type Envs.Ptr;
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := @ + 1;
end Adjust;
function Apply (Item : in Instance;
Args : in Mal.T_Array) return Mal.T
is (Eval_Cb.Cb.all (Ast => Item.F_Ast,
Env => Envs.New_Env (Outer => Item.F_Env,
Binds => Item.F_Params,
Exprs => Args)));
function Apply (Item : in Ptr;
Args : in Mal.T_Array) return Mal.T is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast,
Env => Envs.Sub (Outer => Item.Ref.all.Env,
Binds => Item.Ref.all.Params,
Exprs => Args));
end Apply;
function Ast (Item : in Instance) return Mal.T
is (Item.F_Ast);
function Ast (Item : in Ptr) return Mal.T
is (Item.Ref.all.Ast);
function Env (Item : in Instance) return Envs.Ptr
is (Item.F_Env);
procedure Check_Allocations is
procedure Keep_References (Object : in out Instance) is
begin
pragma Assert (Allocations = 0);
end Check_Allocations;
function Env (Item : in Ptr) return Envs.Closure_Ptr is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Item.Ref.all.Env;
end Env;
procedure Finalize (Object : in out Ptr) is
begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
Object.Ref.all.Refs := @ - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
Mal.Keep (Object.F_Ast);
if Object.F_Env /= null then
Object.F_Env.all.Keep;
end if;
end Finalize;
Mal.Keep (Object.F_Meta);
end Keep_References;
function Params (Item : in Ptr) return Symbols.Symbol_Array
is (Item.Ref.all.Params);
function Meta (Item : in Instance) return Mal.T
is (Item.F_Meta);
function Meta (Item : in Ptr) return Mal.T is
begin
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
return Item.Ref.all.Meta;
end Meta;
function New_Function (Params : in Sequences.Ptr;
function New_Function (Params : in Sequences.Instance;
Ast : in Mal.T;
Env : in Envs.Closure_Ptr)
Env : in Envs.Ptr)
return Mal.T
is
Ref : Acc;
Ref : constant Mal.Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Params.Length,
F_Ast => Ast,
F_Env => Env,
others => <>);
begin
Allocations := Allocations + 1;
-- Avoid exceptions until Ref is controlled.
Ref := new Rec'(Params_Last => Params.Length,
Ast => Ast,
Env => Env,
others => <>);
return R : constant Mal.T := (Kind_Fn, (AFC with Ref)) do
for I in 1 .. Params.Length loop
Err.Check (Params (I).Kind = Kind_Symbol,
"formal parameters must be symbols");
Ref.all.Params (I) := Params (I).Symbol;
end loop;
end return;
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
for I in Ref.all.F_Params'Range loop
Err.Check (Params (I).Kind = Kind_Symbol,
"formal parameters must be symbols");
Ref.all.F_Params (I) := Params (I).Symbol;
end loop;
return (Kind_Fn, Ref);
end New_Function;
function New_Macro (Item : in Ptr) return Mal.T is
-- Avoid raising an exception until Ref is controlled.
Ref : Acc := Item.Ref;
function New_Macro (Item : in Instance) return Mal.T is
Ref : constant Mal.Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Item.Last,
F_Params => Item.F_Params,
F_Ast => Item.F_Ast,
others => <>);
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Env := Envs.Null_Closure;
-- Finalize the environment, it will not be used anymore.
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
Params => Ref.all.Params,
Ast => Ref.all.Ast,
others => <>);
end if;
return (Kind_Macro, (AFC with Ref));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Macro, Ref);
end New_Macro;
function With_Meta (Item : in Ptr;
function Params (Item : in Instance) return Symbols.Symbol_Array
is (Item.F_Params);
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T
is
-- Avoid raising an exception until Ref is controlled.
Ref : Acc := Item.Ref;
Ref : constant Mal.Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Item.Last,
F_Params => Item.F_Params,
F_Ast => Item.F_Ast,
F_Env => Item.F_Env,
F_Meta => Metadata);
begin
pragma Assert (Ref.all.Env /= Envs.Null_Closure);
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Metadata;
else
Allocations := Allocations + 1;
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
Params => Ref.all.Params,
Ast => Ref.all.Ast,
Env => Ref.all.Env,
Meta => Metadata,
others => <>);
end if;
return (Kind_Fn, (AFC with Ref));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Fn, Ref);
end With_Meta;
end Types.Fns;

58
ada.2/types-fns.ads
View File

@ -1,52 +1,48 @@
private with Ada.Finalization;
limited with Envs;
limited with Types.Mal;
limited with Types.Sequences;
limited with Types.Symbols;
with Envs;
with Garbage_Collected;
with Types.Mal;
with Types.Sequences;
with Types.Symbols;
package Types.Fns is
type Ptr is tagged private;
type Instance (<>) is new Garbage_Collected.Instance with private;
-- A pointer to an user-defined function or macro.
function New_Function (Params : in Sequences.Ptr;
function New_Function (Params : in Types.Sequences.Instance;
Ast : in Mal.T;
Env : in Envs.Closure_Ptr) return Mal.T
Env : in Envs.Ptr) return Mal.T
with Inline;
-- Raise an exception if Params contains something else than symbols.
function New_Macro (Item : in Ptr) return Mal.T with Inline;
function New_Macro (Item : in Instance) return Mal.T with Inline;
function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline;
function Ast (Item : in Ptr) return Mal.T with Inline;
function Params (Item : in Instance) return Symbols.Symbol_Array
with Inline;
function Ast (Item : in Instance) return Mal.T with Inline;
-- Useful to print.
function Apply (Item : in Ptr;
function Apply (Item : in Instance;
Args : in Mal.T_Array) return Mal.T with Inline;
-- Fails for macros.
-- Returns null for macros.
function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline;
-- Fails for macros. Required for TCO, instead of Apply.
function Env (Item : in Instance) return Envs.Ptr with Inline;
-- Returns null for macros.
-- Required for TCO, instead of Apply.
function Meta (Item : in Ptr) return Mal.T with Inline;
-- Fails for macros.
function With_Meta (Item : in Ptr;
function Meta (Item : in Instance) return Mal.T with Inline;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T with Inline;
-- Fails for macros.
procedure Check_Allocations;
private
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Acc := null;
end record
with Invariant => Ptr.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);
type Instance (Last : Natural) is new Garbage_Collected.Instance
with record
F_Ast : Mal.T;
F_Env : Envs.Ptr;
F_Meta : Mal.T;
F_Params : Symbols.Symbol_Array (1 .. Last);
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Fns;

34
ada.2/types-mal.adb
View File

@ -1,8 +1,14 @@
with Types.Atoms;
with Types.Builtins;
with Types.Maps;
with Types.Sequences;
with Types.Fns;
package body Types.Mal is
use type Ada.Strings.Unbounded.Unbounded_String;
use type Maps.Ptr;
use type Sequences.Ptr;
use type Maps.Instance;
use type Sequences.Instance;
use type Symbols.Ptr;
----------------------------------------------------------------------
@ -22,11 +28,31 @@ package body Types.Mal is
Right.Kind = Left.Kind and then Left.S = Right.S,
-- Here comes the part that differs from the predefined equality.
when Kind_Sequence =>
Right.Kind in Kind_Sequence and then Left.Sequence = Right.Sequence,
Right.Kind in Kind_Sequence
and then Left.Sequence.all = Right.Sequence.all,
when Kind_Map =>
Right.Kind = Kind_Map and then Left.Map = Right.Map,
Right.Kind = Kind_Map and then Left.Map.all = Right.Map.all,
-- Also, comparing functions is an interesting problem.
when others =>
False);
procedure Keep (Object : in T) is
begin
case Object.Kind is
when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Key | Kind_Builtin
| Kind_Symbol =>
null;
when Kind_Atom =>
Object.Atom.all.Keep;
when Kind_Sequence =>
Object.Sequence.all.Keep;
when Kind_Map =>
Object.Map.all.Keep;
when Kind_Builtin_With_Meta =>
Object.Builtin_With_Meta.all.Keep;
when Kind_Fn | Kind_Macro =>
Object.Fn.all.Keep;
end case;
end Keep;
end Types.Mal;

28
ada.2/types-mal.ads
View File

@ -1,10 +1,10 @@
with Ada.Strings.Unbounded;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Maps;
with Types.Sequences;
limited with Types.Atoms;
limited with Types.Builtins;
limited with Types.Fns;
limited with Types.Maps;
limited with Types.Sequences;
with Types.Symbols;
package Types.Mal is
@ -48,7 +48,13 @@ package Types.Mal is
type T;
type T_Array;
type Atom_Ptr is access Atoms.Instance;
type Builtin_Ptr is access function (Args : in T_Array) return T;
type Builtin_With_Meta_Ptr is access Builtins.Instance;
type Fn_Ptr is access Fns.Instance;
type Map_Ptr is access Maps.Instance;
type Sequence_Ptr is access Sequences.Instance;
type T (Kind : Kind_Type := Kind_Nil) is record
case Kind is
@ -59,21 +65,21 @@ package Types.Mal is
when Kind_Number =>
Number : Integer;
when Kind_Atom =>
Atom : Atoms.Ptr;
Atom : Atom_Ptr;
when Kind_Key =>
S : Ada.Strings.Unbounded.Unbounded_String;
when Kind_Symbol =>
Symbol : Symbols.Ptr;
when Kind_Sequence =>
Sequence : Sequences.Ptr;
Sequence : Sequence_Ptr;
when Kind_Map =>
Map : Maps.Ptr;
Map : Map_Ptr;
when Kind_Builtin =>
Builtin : Builtin_Ptr;
when Kind_Builtin_With_Meta =>
Builtin_With_Meta : Builtins.Ptr;
Builtin_With_Meta : Builtin_With_Meta_Ptr;
when Kind_Fn | Kind_Macro =>
Fn : Fns.Ptr;
Fn : Fn_Ptr;
end case;
end record;
@ -83,6 +89,8 @@ package Types.Mal is
Nil : constant T := (Kind => Kind_Nil);
procedure Keep (Object : in Mal.T) with Inline;
type T_Array is array (Positive range <>) of T;
end Types.Mal;

252
ada.2/types-maps.adb
View File

@ -1,151 +1,77 @@
with Ada.Containers.Hashed_Maps;
with Ada.Strings.Unbounded.Hash;
with Ada.Unchecked_Deallocation;
with Err;
with Types.Sequences;
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;
-- This function also checks the kind of the key, and raise an
-- error in case of problem.
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);
Allocations : Natural := 0;
function Constructor return Mal.Map_Ptr with Inline;
----------------------------------------------------------------------
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 := @ + 1;
end Adjust;
function "=" (Left, Right : in Instance) return Boolean
is (Left.Data = Right.Data);
function Assoc (Args : in Mal.T_Array) return Mal.T is
Ref : Acc;
Ref : constant Mal.Map_Ptr := Constructor;
begin
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
-- Avoid exceptions until Ref is controlled.
Ref := Args (Args'First).Map.Ref;
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Ref.all.Data,
others => <>);
end if;
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
for I in 1 .. Args'Length / 2 loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
New_Item => Args (Args'First + 2 * I));
-- This call checks the kind of the key.
end loop;
end return;
Ref.all.Data := Args (Args'First).Map.all.Data;
for I in 1 .. Args'Length / 2 loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
New_Item => Args (Args'First + 2 * I));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
end Assoc;
procedure Check_Allocations is
begin
pragma Assert (Allocations = 0);
end Check_Allocations;
function Contains (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
return (Kind_Boolean,
Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)));
Args (Args'First).Map.all.Data.Contains (Args (Args'Last)));
end Contains;
function Constructor return Mal.Map_Ptr is
Ref : constant Mal.Map_Ptr := new Instance;
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return Ref;
end Constructor;
function Dissoc (Args : in Mal.T_Array) return Mal.T is
Ref : Acc;
Ref : constant Mal.Map_Ptr := Constructor;
begin
Err.Check (0 < Args'Length, "expected at least 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
-- Avoid exceptions until Ref is controlled.
Ref := Args (Args'First).Map.Ref;
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Ref.all.Data,
others => <>);
end if;
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
for I in Args'First + 1 .. Args'Last loop
Ref.all.Data.Exclude (Args (I));
-- This call checks the kind of the key.
end loop;
end return;
Ref.all.Data := Args (Args'First).Map.all.Data;
for I in Args'First + 1 .. Args'Last loop
Ref.all.Data.Exclude (Args (I));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
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 := @ - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
end if;
end Finalize;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Mal.T
function Generic_Eval (Container : in Instance;
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.
-- Avoid exceptions until Ref is controlled.
Ref : Acc := Container.Ref;
Ref : constant Mal.Map_Ptr := Constructor;
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Ref.all.Data,
others => <>);
end if;
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));
-- This call may raise exceptions.
end loop;
end return;
Ref.Data := Container.Data;
for Position in Ref.all.Data.Iterate loop
Ref.all.Data.Replace_Element (Position,
Eval (HM.Element (Position), Env));
-- This call may raise exceptions.
end loop;
return Mal.T'(Kind_Map, Ref);
end Generic_Eval;
function Get (Args : in Mal.T_Array) return Mal.T is
@ -158,8 +84,7 @@ package body Types.Maps is
"key must be a keyword or string");
return Mal.Nil;
when Kind_Map =>
Position
:= Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last));
Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last));
-- This call checks the kind of the key.
if HM.Has_Element (Position) then
return HM.Element (Position);
@ -179,86 +104,83 @@ package body Types.Maps is
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
Binds : constant Natural := Args'Length / 2;
Ref : Acc;
Ref : Mal.Map_Ptr;
begin
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
Allocations := Allocations + 1;
-- Avoid exceptions until Ref is controlled.
Ref := new Rec;
Ref := Constructor;
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
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));
-- This call checks the kind of the key.
end loop;
end return;
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));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
end Hash_Map;
procedure Iterate (Container : in Ptr) is
procedure Iterate (Container : in Instance) is
begin
for Position in Container.Ref.all.Data.Iterate loop
for Position in Container.Data.Iterate loop
Process (HM.Key (Position), HM.Element (Position));
end loop;
end Iterate;
procedure Keep_References (Object : in out Instance) is
begin
for Position in Object.Data.Iterate loop
Mal.Keep (HM.Key (Position));
Mal.Keep (HM.Element (Position));
end loop;
Mal.Keep (Object.F_Meta);
end Keep_References;
function Keys (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
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 Sequences.List (R);
end;
A1 := Args (Args'First).Map;
R := Sequences.Constructor (A1.all.Length);
for Position in A1.all.Data.Iterate loop
R.all.Replace_Element (I, HM.Key (Position));
I := I + 1;
end loop;
return (Kind_List, R);
end Keys;
function Meta (Container : in Ptr) return Mal.T
is (Container.Ref.all.Meta);
function Length (Container : in Instance) return Natural
is (Natural (Container.Data.Length));
function Meta (Container : in Instance) return Mal.T
is (Container.F_Meta);
function Vals (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
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 Sequences.List (R);
end;
A1 := Args (Args'First).Map;
R := Sequences.Constructor (A1.all.Length);
for Element of A1.all.Data loop
R.all.Replace_Element (I, Element);
I := I + 1;
end loop;
return (Kind_List, R);
end Vals;
function With_Meta (Data : in Ptr;
Metadata : in Mal.T)
return Mal.T
function With_Meta (Data : in Instance;
Metadata : in Mal.T) return Mal.T
is
-- Avoid exceptions until Ref is controlled.
Ref : Acc := Data.Ref;
Ref : constant Mal.Map_Ptr := Constructor;
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Metadata;
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Ref.all.Data,
Meta => Metadata,
others => <>);
end if;
return (Kind_Map, (AFC with Ref));
Ref.all.Data := Data.Data;
Ref.all.F_Meta := Metadata;
return (Kind_Map, Ref);
end With_Meta;
end Types.Maps;

49
ada.2/types-maps.ads
View File

@ -1,10 +1,11 @@
private with Ada.Finalization;
private with Ada.Containers.Hashed_Maps;
limited with Types.Mal;
with Garbage_Collected;
with Types.Mal;
package Types.Maps is
type Ptr is tagged private;
type Instance (<>) is new Garbage_Collected.Instance with private;
-- Built-in functions.
function Assoc (Args : in Mal.T_Array) return Mal.T;
@ -15,17 +16,19 @@ package Types.Maps is
function Keys (Args : in Mal.T_Array) return Mal.T;
function Vals (Args : in Mal.T_Array) return Mal.T;
function "=" (Left, Right : in Instance) return Boolean with Inline;
-- 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;
function Generic_Eval (Container : in Instance;
Env : in Env_Type)
return Mal.T;
@ -33,28 +36,32 @@ package Types.Maps is
generic
with procedure Process (Key : in Mal.T;
Element : in Mal.T);
procedure Iterate (Container : in Ptr);
procedure Iterate (Container : in Instance);
function Meta (Container : in Ptr) return Mal.T with Inline;
function Length (Container : in Instance) return Natural with Inline;
function With_Meta (Data : in Ptr;
function Meta (Container : in Instance) return Mal.T with Inline;
function With_Meta (Data : in Instance;
Metadata : in Mal.T)
return Mal.T;
-- Debug
procedure Check_Allocations;
private
type Rec;
type Acc is access Rec;
type Ptr is new Ada.Finalization.Controlled with record
Ref : Acc := null;
end record
with Invariant => Ptr.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);
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline;
-- This function also checks the kind of the key, and raise an
-- error in case of problem.
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 Instance is new Garbage_Collected.Instance with record
Data : HM.Map;
F_Meta : Mal.T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Maps;

238
ada.2/types-sequences.adb
View File

@ -1,68 +1,44 @@
with Ada.Unchecked_Deallocation;
with Err;
with Types.Mal;
with Types.Builtins;
with Types.Fns;
package body Types.Sequences 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);
Allocations : Natural := 0;
----------------------------------------------------------------------
function "=" (Left, Right : in Ptr) return Boolean is
function "=" (Left, Right : in Instance) 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));
return Left.Last = Right.Last
and then
(for all I in 1 .. Left.Last => Left.Data (I) = Right.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 := @ + 1;
end Adjust;
procedure Check_Allocations is
begin
pragma Assert (Allocations = 0);
end Check_Allocations;
Right : in Instance) return Mal.T_Array
is (Left & Right.Data);
function Concat (Args : in Mal.T_Array) return Mal.T is
Sum : Natural := 0;
First : Positive := 1;
Last : Natural;
Ref : Acc;
Ref : Mal.Sequence_Ptr;
begin
for Arg of Args loop
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences");
Sum := Sum + Arg.Sequence.Ref.all.Data'Length;
Sum := Sum + Arg.Sequence.all.Data'Length;
end loop;
Allocations := Allocations + 1;
-- Avoid exceptions until Ref is controlled.
Ref := new Rec (Sum);
Ref := Constructor (Sum);
for Arg of Args loop
Last := First - 1 + Arg.Sequence.Ref.all.Data'Length;
Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data;
Last := First - 1 + Arg.Sequence.all.Data'Length;
Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
First := Last + 1;
end loop;
return (Kind_List, (AFC with Ref));
return (Kind_List, Ref);
end Concat;
function Conj (Args : in Mal.T_Array) return Mal.T is
@ -71,21 +47,20 @@ package body Types.Sequences is
case Args (Args'First).Kind is
when Kind_Sequence =>
declare
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
Last : constant Natural := Args'Length - 1 + Data'Length;
-- Avoid exceptions until Ref is controlled.
Ref : constant Acc := new Rec (Last);
Ref : constant Mal.Sequence_Ptr := Constructor (Last);
begin
Allocations := Allocations + 1;
if Args (Args'First).Kind = Kind_List then
for I in 1 .. Args'Length - 1 loop
Ref.all.Data (I) := Args (Args'Last - I + 1);
end loop;
Ref.all.Data (Args'Length .. Last) := Data;
return (Kind_List, (AFC with Ref));
return (Kind_List, Ref);
else
Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
return (Kind_Vector, (AFC with Ref));
return (Kind_Vector, Ref);
end if;
end;
when others =>
@ -100,15 +75,21 @@ package body Types.Sequences is
"parameter 2 must be a sequence");
declare
Head : Mal.T renames Args (Args'First);
Tail : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
Tail : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Mal.Sequence_Ptr := Constructor (1 + Tail'Length);
begin
Allocations := Allocations + 1;
return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length,
Data => Head & Tail,
others => <>)));
Ref.all.Data := Head & Tail;
return (Kind_List, Ref);
end;
end Cons;
function Constructor (Length : in Natural) return Mal.Sequence_Ptr is
Ref : constant Mal.Sequence_Ptr := new Instance (Length);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return Ref;
end Constructor;
function Count (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
@ -116,28 +97,15 @@ package body Types.Sequences is
when Kind_Nil =>
return (Kind_Number, 0);
when Kind_Sequence =>
return (Kind_Number, Args (Args'First).Sequence.Ref.all.Data'Length);
return (Kind_Number, Args (Args'First).Sequence.all.Data'Length);
when others =>
Err.Raise_With ("parameter must be nil or a sequence");
end case;
end Count;
function Element (Container : in Ptr;
function Element (Container : in Instance;
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 := @ - 1;
if 0 < Object.Ref.all.Refs then
Object.Ref := null;
else
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
end if;
end Finalize;
is (Container.Data (Index));
function First (Args : in Mal.T_Array) return Mal.T is
begin
@ -147,7 +115,7 @@ package body Types.Sequences is
return Mal.Nil;
when Kind_Sequence =>
declare
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
begin
if Data'Length = 0 then
return Mal.Nil;
@ -160,48 +128,30 @@ package body Types.Sequences is
end case;
end First;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Ptr
is
-- Avoid exceptions until Ref is controlled.
Ref : Acc := Container.Ref;
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec (Ref.all.Last);
end if;
return R : constant Ptr := (AFC with Ref) do
for I in Container.Ref.all.Data'Range loop
Ref.all.Data (I) := Eval (Container.Ref.all.Data (I), Env);
-- This call may raise exceptions.
-- The target may be the source.
end loop;
end return;
end Generic_Eval;
function Is_Empty (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind in Kind_Sequence,
"parameter must be a sequence");
return (Kind_Boolean,
Args (Args'First).Sequence.Ref.all.Data'Length = 0);
return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
end Is_Empty;
function Length (Source : in Ptr) return Natural
is (Source.Ref.all.Data'Length);
procedure Keep_References (Object : in out Instance) is
begin
Mal.Keep (Object.F_Meta);
for M of Object.Data loop
Mal.Keep (M);
end loop;
end Keep_References;
function Length (Source : in Instance) return Natural
is (Source.Data'Length);
function List (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
begin
Allocations := Allocations + 1;
return (Kind_List, (AFC with new Rec'(Data => Args,
Last => Args'Length,
others => <>)));
Ref.all.Data := Args;
return (Kind_List, Ref);
end List;
function Map (Args : in Mal.T_Array) return Mal.T is
@ -211,44 +161,32 @@ package body Types.Sequences is
"parameter 2 must be a sequence");
declare
F : Mal.T renames Args (Args'First);
Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
-- Avoid exceptions until Ref is controlled.
Ref : Acc := Args (Args'Last).Sequence.Ref;
Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length);
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Mal.Nil;
else
Allocations := Allocations + 1;
Ref := new Rec (Ref.all.Last);
end if;
return R : constant Mal.T := (Kind_List, (AFC with Ref)) do
case F.Kind is
case F.Kind is
when Kind_Builtin =>
for I in Src'Range loop
Ref.all.Data (I) := F.Builtin.all (Src (I .. I));
-- This call may raise exceptions.
-- The target may be the same storage than the source.
end loop;
when Kind_Builtin_With_Meta =>
for I in Src'Range loop
Ref.all.Data (I)
:= F.Builtin_With_Meta.Builtin.all (Src (I .. I));
:= F.Builtin_With_Meta.all.Builtin.all (Src (I .. I));
end loop;
when Kind_Fn =>
for I in Src'Range loop
Ref.all.Data (I) := F.Fn.Apply (Src (I .. I));
Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I));
end loop;
when others =>
Err.Raise_With ("parameter 1 must be a function");
end case;
end return;
end case;
return (Kind_List, Ref);
end;
end Map;
function Meta (Item : in Ptr) return Mal.T
is (Item.Ref.all.Meta);
function Meta (Item : in Instance) return Mal.T
is (Item.F_Meta);
function Nth (Args : in Mal.T_Array) return Mal.T is
begin
@ -258,7 +196,7 @@ package body Types.Sequences is
Err.Check (Args (Args'Last).Kind = Kind_Number,
"parameter 2 must be a number");
declare
L : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
L : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
I : constant Integer := Args (Args'Last).Number + 1;
begin
Err.Check (I in L'Range, "index out of bounds");
@ -266,70 +204,62 @@ package body Types.Sequences is
end;
end Nth;
procedure Replace_Element (Container : in out Instance;
Index : in Positive;
New_Item : in Mal.T)
is
begin
Container.Data (Index) := New_Item;
end Replace_Element;
function Rest (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
declare
A1 : Mal.T renames Args (Args'First);
Ref : Acc;
Ref : Mal.Sequence_Ptr;
begin
-- Avoid exceptions until Ref is controlled.
case A1.Kind is
when Kind_Nil =>
Allocations := Allocations + 1;
Ref := new Rec (0);
Ref := Constructor (0);
when Kind_Sequence =>
Allocations := Allocations + 1;
if A1.Sequence.Ref.all.Last = 0 then
Ref := new Rec (0);
if A1.Sequence.all.Last = 0 then
Ref := Constructor (0);
else
Ref := new Rec'
(Last => A1.Sequence.Ref.all.Last - 1,
Data => A1.Sequence.Ref.all.Data
(2 .. A1.Sequence.Ref.all.Data'Last),
others => <>);
Ref := Constructor (A1.Sequence.all.Last - 1);
Ref.all.Data
:= A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last);
end if;
when others =>
Err.Raise_With ("parameter must be nil or a sequence");
end case;
return (Kind_List, (AFC with Ref));
return (Kind_List, Ref);
end;
end Rest;
function Tail (Source : in Ptr;
function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array is
Data : Mal.T_Array renames Source.Ref.all.Data;
Data : Mal.T_Array renames Source.Data;
begin
return Data (Data'Last - Count + 1 .. Data'Last);
end Tail;
function Vector (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
begin
Allocations := Allocations + 1;
return (Kind_Vector, (AFC with new Rec'(Data => Args,
Last => Args'Length,
others => <>)));
Ref.all.Data := Args;
return (Kind_Vector, Ref);
end Vector;
function With_Meta (Data : in Ptr;
Metadata : in Mal.T) return Ptr
function With_Meta (Data : in Instance;
Metadata : in Mal.T) return Mal.Sequence_Ptr
is
-- Avoid exceptions until Ref is controlled.
Ref : Acc := Data.Ref;
Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last);
begin
pragma Assert (0 < Ref.all.Refs);
if Ref.all.Refs = 1 then
Ref.all.Refs := 2;
Ref.all.Meta := Metadata;
else
Allocations := Allocations + 1;
Ref := new Rec'(Last => Ref.all.Last,
Data => Ref.all.Data,
Meta => Metadata,
others => <>);
end if;
return (AFC with Ref);
Ref.all.Data := Data.Data;
Ref.all.F_Meta := Metadata;
return Ref;
end With_Meta;
end Types.Sequences;

65
ada.2/types-sequences.ads
View File

@ -1,10 +1,9 @@
private with Ada.Finalization;
limited with Types.Mal;
with Garbage_Collected;
with Types.Mal;
package Types.Sequences is
type Ptr is tagged private
type Instance (<>) is new Garbage_Collected.Instance with private
with Constant_Indexing => Element;
-- Built-in functions.
@ -20,59 +19,41 @@ package Types.Sequences is
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 "=" (Left, Right : in Instance) return Boolean with Inline;
function Element (Container : in Ptr;
function Length (Source : in Instance) return Natural with Inline;
function Element (Container : in Instance;
Index : in Positive) return Mal.T
with Inline, Pre => Index <= Length (Container);
function "&" (Left : in Mal.T_Array;
Right : in Ptr) return Mal.T_Array;
Right : in Instance) return Mal.T_Array with Inline;
-- 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;
function Constructor (Length : in Natural) return Mal.Sequence_Ptr
with Inline;
procedure Replace_Element (Container : in out Instance;
Index : in Positive;
New_Item : in Mal.T)
with Inline, Pre => Index <= Length (Container);
-- Used in macro implementation.
function Tail (Source : in Ptr;
function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array
with Inline, Pre => Count <= Length (Source);
function Meta (Item : in Ptr) return Mal.T with Inline;
function With_Meta (Data : in Ptr;
function Meta (Item : in Instance) return Mal.T with Inline;
function With_Meta (Data : in Instance;
Metadata : in Mal.T)
return Ptr;
-- Debug.
procedure Check_Allocations;
return Mal.Sequence_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 => Ptr.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);
type Instance (Last : Natural) is new Garbage_Collected.Instance with record
F_Meta : Mal.T;
Data : Mal.T_Array (1 .. Last);
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Sequences;

44
ada.2/types-symbols.adb
View File

@ -1,42 +1,31 @@
with Ada.Containers.Ordered_Sets;
with Ada.Containers.Hashed_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);
Allocations : Natural := 0;
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 Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline;
package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc,
Hash => Hash,
Equivalent_Elements => "=",
"=" => "=");
function Key (Item : in Acc) return String with Inline;
package Keys is new Sets.Generic_Keys (Key_Type => String,
Key => Key,
"<" => Standard."<");
package Keys is new Sets.Generic_Keys (Key_Type => String,
Key => Key,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=");
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 := @ + 1;
@ -59,7 +48,6 @@ package body Types.Symbols is
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Source,
Hash => Ada.Strings.Hash (Source),
Last => Source'Length,
Refs => 1);
Dict.Insert (Ref);
@ -67,13 +55,6 @@ package body Types.Symbols is
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
@ -88,8 +69,11 @@ package body Types.Symbols is
end if;
end Finalize;
function Hash (Item : in Acc) return Ada.Containers.Hash_Type
is (Ada.Strings.Hash (Item.all.Data));
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
is (Item.Ref.all.Hash);
is (Ada.Strings.Hash (Item.Ref.all.Data));
function Key (Item : in Acc) return String
is (Item.all.Data);

21
ada.2/types-symbols.ads
View File

@ -3,6 +3,10 @@ private with Ada.Finalization;
package Types.Symbols with Preelaborate is
-- Like keys, symbols are immutable final nodes in the internal
-- data structures. For them, reference counting is probably more
-- efficient than garbage collecting.
type Ptr is tagged private;
function Constructor (Source : in String) return Ptr with Inline;
@ -13,12 +17,18 @@ package Types.Symbols with Preelaborate is
-- 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.
-- The implementation ensures that a given content is only
-- allocated once, so equality of pointers gives the same result
-- than comparing the strings.
type Symbol_Array is array (Positive range <>) of Symbols.Ptr;
type Symbol_Array is array (Positive range <>) of Ptr;
Empty_Array : constant Symbol_Array;
-- It is convenient to define this here because the default value
-- for Ptr is invalid.
-- Debug.
procedure Check_Allocations;
procedure Check_Allocations with Inline;
-- Does nothing if assertions are disabled.
private
@ -49,4 +59,9 @@ private
-- Predefined equality is fine.
pragma Finalize_Storage_Only (Ptr);
Empty_Array : constant Symbol_Array
:= (1 .. 0 => (Ada.Finalization.Controlled with null));
-- This will not trigger the invariant check because no element is
-- ever actually instantiated.
end Types.Symbols;