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

Merge pull request #348 from asarhaddon/ada.2

Browse Source 
ada.2: fix memory leaks with garbage collection. Various simplifications.
This commit is contained in:
Joel Martin 2019-03-31 19:16:53 -05:00 committed by GitHub
commit 15b8d6aa9d
No known key found for this signature in database
GPG Key ID: 4AEE18F83AFDEB23
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 \ envs.ads envs.adb \
err.ads err.adb \ err.ads err.adb \
eval_cb.ads \ eval_cb.ads \
garbage_collected.ads garbage_collected.adb \
printer.ads printer.adb \ printer.ads printer.adb \
reader.ads reader.adb \ reader.ads reader.adb \
readline.ads \ 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 * Lists are implemented as C-style arrays, and most of them can be
allocated on the stack. allocated on the stack.
Once each component has an explicit interface, various optimizations Another difference is that a minimal form of garbage collecting is
have been added: unique allocation of symbols, stack-style allocation implemented, removing objects not referenced from the main
of environments in the current execution path, reuse of allocated environment. Reference counting is convenient for symbols or strings,
memory when the reference count reaches 1... 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 The eventual performances compete with C-style languages, allthough
all user input is checked (implicit language-defined checks like array all user input is checked (implicit language-defined checks like array
bounds and discriminant consistency are only enabled during tests). 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. 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. ensuring a valid value during elaboration.
Note that generic packages cannot export access values. 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 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 here we want the type to become a field inside Types.Mal.T. So the
check happens at run time with a private invariant. 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 the reference count is zero, meaning that we are reaching Finalize
recursively. recursively.
* In implementations, a consistent object (that will be deallocated * In implementations with reference counting, a consistent object
automatically) must be built before any exception is raised by user (that will be deallocated automatically) must be built before any
code (for example the 'map' built-in function may run user code). 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 * Each module encapsulating dynamic allocation counts allocations and
deallocations. With debugging options, a failure is reported if deallocations. With debugging options, a failure is reported if
- too many deallocation happen (via a numeric range check) - too many deallocation happen (via a numeric range check)
- all storage is not freed (via a dedicated call from the step file) - 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 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. backported to former steps as this is really handy for debugging.
Some environment variables increase verbosity. Some environment variables increase verbosity.
# dbg_reader= ./stepAmal trace reader recursion # dbgread= ./stepAmal trace reader recursion
# dbgeval= ./stepAmal eval recursion (or TCO) # dbgeval= ./stepAmal trace eval recursion (including TCO)
# dbgenv0= ./stepAmal eval recursion and environments contents
# dbgenv1= ./stepAmal eval recursion and environment internals

44
ada.2/core.adb
View File

@ -3,11 +3,10 @@ with Ada.Characters.Latin_1;
with Ada.Strings.Unbounded; with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO; with Ada.Text_IO.Unbounded_IO;
with Envs;
with Err; with Err;
with Eval_Cb;
with Types.Atoms; with Types.Atoms;
with Types.Builtins; with Types.Builtins;
with Types.Fns;
with Types.Mal; with Types.Mal;
with Types.Maps; with Types.Maps;
with Types.Sequences; with Types.Sequences;
@ -64,7 +63,6 @@ package body Core is
function Apply (Args : in Mal.T_Array) return Mal.T; function Apply (Args : in Mal.T_Array) return Mal.T;
function Division is new Generic_Mal_Operator ("/"); function Division is new Generic_Mal_Operator ("/");
function Equals (Args : in Mal.T_Array) return Mal.T; 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_Equal is new Generic_Comparison (">=");
function Greater_Than is new Generic_Comparison (">"); function Greater_Than is new Generic_Comparison (">");
function Is_Atom is new Generic_Kind_Test (Kind_Atom); 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, Err.Check (Args (Args'Last).Kind in Kind_Sequence,
"last parameter must be a sequence"); "last parameter must be a sequence");
declare declare
use type Sequences.Ptr; use type Sequences.Instance;
F : Mal.T renames Args (Args'First); F : Mal.T renames Args (Args'First);
A : constant Mal.T_Array A : constant Mal.T_Array
:= Args (Args'First + 1 .. Args'Last - 1) := Args (Args'First + 1 .. Args'Last - 1)
& Args (Args'Last).Sequence; & Args (Args'Last).Sequence.all;
begin begin
case F.Kind is case F.Kind is
when Kind_Builtin => when Kind_Builtin =>
return F.Builtin.all (A); return F.Builtin.all (A);
when Kind_Builtin_With_Meta => 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 => when Kind_Fn =>
return F.Fn.Apply (A); return F.Fn.all.Apply (A);
when others => when others =>
Err.Raise_With ("parameter 1 must be a function"); Err.Raise_With ("parameter 1 must be a function");
end case; end case;
@ -134,13 +132,6 @@ package body Core is
return (Kind_Boolean, Args (Args'First) = Args (Args'Last)); return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
end Equals; 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 function Is_False (Args : in Mal.T_Array) return Mal.T is
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
@ -188,13 +179,13 @@ package body Core is
begin begin
case A1.Kind is case A1.Kind is
when Kind_Sequence => when Kind_Sequence =>
return A1.Sequence.Meta; return A1.Sequence.all.Meta;
when Kind_Map => when Kind_Map =>
return A1.Map.Meta; return A1.Map.all.Meta;
when Kind_Fn => when Kind_Fn =>
return A1.Fn.Meta; return A1.Fn.all.Meta;
when Kind_Builtin_With_Meta => when Kind_Builtin_With_Meta =>
return A1.Builtin_With_Meta.Meta; return A1.Builtin_With_Meta.all.Meta;
when Kind_Builtin => when Kind_Builtin =>
return Mal.Nil; return Mal.Nil;
when others => when others =>
@ -203,14 +194,14 @@ package body Core is
end; end;
end Meta; end Meta;
procedure NS_Add_To_Repl is procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is
procedure P (S : in Symbols.Ptr; procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr) with Inline; B : in Mal.Builtin_Ptr) with Inline;
procedure P (S : in Symbols.Ptr; procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr) B : in Mal.Builtin_Ptr)
is is
begin begin
Envs.Repl.Set (S, (Kind_Builtin, B)); Repl.all.Set (S, (Kind_Builtin, B));
end P; end P;
begin begin
P (Symbols.Constructor ("+"), Addition'Access); P (Symbols.Constructor ("+"), Addition'Access);
@ -227,7 +218,6 @@ package body Core is
P (Symbols.Constructor ("/"), Division'Access); P (Symbols.Constructor ("/"), Division'Access);
P (Symbols.Constructor ("do"), Mal_Do'Access); P (Symbols.Constructor ("do"), Mal_Do'Access);
P (Symbols.Constructor ("="), Equals'Access); P (Symbols.Constructor ("="), Equals'Access);
P (Symbols.Constructor ("eval"), Eval'Access);
P (Symbols.Constructor ("first"), Sequences.First'Access); P (Symbols.Constructor ("first"), Sequences.First'Access);
P (Symbols.Constructor ("get"), Maps.Get'Access); P (Symbols.Constructor ("get"), Maps.Get'Access);
P (Symbols.Constructor (">="), Greater_Equal'Access); P (Symbols.Constructor (">="), Greater_Equal'Access);
@ -360,7 +350,7 @@ package body Core is
end; end;
end if; end if;
when Kind_Sequence => when Kind_Sequence =>
if Args (Args'First).Sequence.Length = 0 then if Args (Args'First).Sequence.all.Length = 0 then
return Mal.Nil; return Mal.Nil;
else else
return (Kind_List, Args (Args'First).Sequence); return (Kind_List, Args (Args'First).Sequence);
@ -427,17 +417,17 @@ package body Core is
begin begin
case A1.Kind is case A1.Kind is
when Kind_Builtin_With_Meta => 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 => when Kind_Builtin =>
return Builtins.With_Meta (A1.Builtin, A2); return Builtins.With_Meta (A1.Builtin, A2);
when Kind_List => when Kind_List =>
return (Kind_List, A1.Sequence.With_Meta (A2)); return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2));
when Kind_Vector => when Kind_Vector =>
return (Kind_Vector, A1.Sequence.With_Meta (A2)); return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2));
when Kind_Map => when Kind_Map =>
return A1.Map.With_Meta (A2); return Maps.With_Meta (A1.Map.all, A2);
when Kind_Fn => when Kind_Fn =>
return A1.Fn.With_Meta (A2); return Fns.With_Meta (A1.Fn.all, A2);
when others => when others =>
Err.Raise_With Err.Raise_With
("parameter 1 must be a function, map or sequence"); ("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 package Core with Elaborate_Body is
procedure NS_Add_To_Repl; procedure NS_Add_To_Repl (Repl : in Envs.Ptr);
-- Add built-in functions to Envs.Repl. -- Add built-in functions.
end Core; 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.Text_IO.Unbounded_IO;
with Ada.Unchecked_Deallocation;
with Err; with Err;
with Printer; with Printer;
@ -11,417 +9,93 @@ package body Envs is
use Types; 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 procedure Dump_Stack (Env : in Instance) 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
use Ada.Text_IO; use Ada.Text_IO;
begin begin
for I in 1 .. Top loop Put_Line ("environment:");
if Long then for P in Env.Data.Iterate loop
Put ("Level"); -- Do not print builtins for repl.
end if; if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then
Put (I'Img); Put (" ");
if Long then Put (HM.Key (P).To_String);
Put (':');
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
New_Line; 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; 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; end loop;
if Env.Outer /= null then
Put ("outer is ");
Env.Outer.all.Dump_Stack;
end if;
end Dump_Stack; end Dump_Stack;
procedure Finalize (Object : in out Closure_Ptr) is function Get (Env : in Instance;
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;
Key : in Symbols.Ptr) return Mal.T Key : in Symbols.Ptr) return Mal.T
is is
pragma Assert (Evt.Index in 1 | Top); -- Trust the compiler to detect the tail call. A loop would
Index : Stack_Index := Evt.Index; -- require a Ptr parameter or a separated first iteration.
Ref : Heap_Access; Position : constant HM.Cursor := Env.Data.Find (Key);
Definition : HM.Cursor;
begin begin
Main_Loop : loop if HM.Has_Element (Position) then
Index_Loop : loop return HM.Element (Position);
Definition := Stack (Index).Data.Find (Key); end if;
if HM.Has_Element (Definition) then Err.Check (Env.Outer /= null,
return HM.Element (Definition); "'" & Symbols.To_String (Key) & "' not found");
end if; return Env.Outer.all.Get (Key);
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");
end Get; end Get;
function New_Closure (Env : in Ptr'Class) return Closure_Ptr is procedure Keep_References (Object : in out Instance) is
pragma Assert (Env.Index in 1 | Top); -- Same remarks than for Get.
Alias : Heap_Access renames Stack (Env.Index).Alias;
begin begin
if Alias = null then for Element of Object.Data loop
Allocations := Allocations + 1; Mal.Keep (Element);
Alias := new Heap_Record'(Index => Env.Index, others => <>); end loop;
else if Object.Outer /= null then
Alias.all.Refs := @ + 1; Object.Outer.all.Keep;
end if; end if;
return (Ada.Finalization.Controlled with Alias); end Keep_References;
end New_Closure;
procedure Replace_With_Sub (Env : in out Ptr) is function New_Env (Outer : in Ptr := null;
pragma Assert (Env.Index in 1 | Top); Binds : in Symbols.Symbol_Array := No_Binds;
R : Stack_Record renames Stack (Env.Index); Exprs : in Mal.T_Array := No_Exprs) return Ptr
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)
is is
use type Symbols.Ptr; use type Symbols.Ptr;
Varargs : constant Boolean := 1 < Binds'Length and then Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with
Binds (Binds'Last - 1) = Symbols.Names.Ampersand; Outer => Outer,
Data => HM.Empty_Map);
begin begin
Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
else Exprs'Length = Binds'Length), if 2 <= Binds'Length
"actual parameters do not match formal parameters"); and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop then
M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I)); Err.Check (Binds'Length - 2 <= Exprs'Length,
end loop; "not enough actual parameters for vararg function");
if Varargs then for I in 0 .. Binds'Length - 3 loop
M.Include (Binds (Binds'Last), Sequences.List Ref.all.Data.Include (Key => Binds (Binds'First + I),
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last))); 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 if;
end Set_Binds; return Ref;
end New_Env;
function Sub (Outer : in Ptr; procedure Set (Env : in out Instance;
Binds : in Symbols.Symbol_Array; Key : in Symbols.Ptr;
Exprs : in Mal.T_Array) return Ptr New_Item : in Mal.T)
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
is is
begin begin
Outer.Ref.all.Refs := @ + 1; Env.Data.Include (Key, New_Item);
Top := Top + 1; end Set;
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;
end Envs; 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.Mal;
with Types.Symbols; with Types.Symbols;
package Envs with Elaborate_Body is package Envs is
-- This package should be named Env, but Ada does not allow formal -- This package should be named Env, but Ada does not allow formal
-- parameters to be named like a package dependency, and it seems -- parameters to be named like a package dependency, and it seems
-- that readability inside Eval is more important. -- that readability inside Eval is more important.
-- This implementation relies on the fact that the caller only type Instance (<>) is new Garbage_Collected.Instance with private;
-- ever references environments in its execution stack. type Ptr is access Instance;
-- When a function closure references an environment that the No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array;
-- execution leaves behind, a dynamically allocated block is used No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil);
-- instead.
-- The eval built-in requires REPL (see the implementation of function New_Env (Outer : in Ptr := null;
-- load-file), so we cannot assume that the caller only sees the Binds : in Types.Symbols.Symbol_Array := No_Binds;
-- current environment. Exprs : in Types.Mal.T_Array := No_Exprs)
return Ptr;
type Ptr (<>) is tagged limited private; function Get (Env : in Instance;
-- 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;
Key : in Types.Symbols.Ptr) return Types.Mal.T; 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; -- Debug.
Null_Closure : constant Closure_Ptr; procedure Dump_Stack (Env : in Instance);
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;
private private
-- There must be a reference level so that functions may keep package HM is new Ada.Containers.Hashed_Maps
-- track of their initial environment, and another one for (Key_Type => Types.Symbols.Ptr,
-- reallocations. The second one is delegated to a predefined Ada Element_Type => Types.Mal.T,
-- container. Hash => Types.Symbols.Hash,
Equivalent_Keys => Types.Symbols."=",
"=" => Types.Mal."=");
-- MAL maps may be tempting, but we do not want to copy the whole type Instance is new Garbage_Collected.Instance with record
-- map for each addition or removal. Outer : Ptr;
Data : HM.Map;
-- 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;
end record; end record;
overriding procedure Adjust (Object : in out Closure_Ptr) with Inline; overriding procedure Keep_References (Object : in out Instance) with Inline;
overriding procedure Finalize (Object : in out Closure_Ptr) with Inline;
pragma Finalize_Storage_Only (Closure_Ptr);
Null_Closure : constant Closure_Ptr
:= (Ada.Finalization.Controlled with null);
end Envs; 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. -- Helpers for Print_Form.
procedure Print_Number (Number : in Integer) with Inline; procedure Print_Number (Number : in Integer) with Inline;
procedure Print_List (List : in Sequences.Ptr) with Inline; procedure Print_List (List : in Sequences.Instance) with Inline;
procedure Print_Map (Map : in Maps.Ptr) with Inline; procedure Print_Map (Map : in Maps.Instance) with Inline;
procedure Print_Readably (S : in Unbounded_String) 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"); Append (Buffer, "false");
end if; end if;
when Kind_Symbol => when Kind_Symbol =>
Append (Buffer, Form_Ast.Symbol.To_String); Append (Buffer, Symbols.To_String (Form_Ast.Symbol));
when Kind_Number => when Kind_Number =>
Print_Number (Form_Ast.Number); Print_Number (Form_Ast.Number);
when Kind_Keyword => when Kind_Keyword =>
@ -57,34 +57,34 @@ package body Printer is
end if; end if;
when Kind_List => when Kind_List =>
Append (Buffer, '('); Append (Buffer, '(');
Print_List (Form_Ast.Sequence); Print_List (Form_Ast.Sequence.all);
Append (Buffer, ')'); Append (Buffer, ')');
when Kind_Vector => when Kind_Vector =>
Append (Buffer, '['); Append (Buffer, '[');
Print_List (Form_Ast.Sequence); Print_List (Form_Ast.Sequence.all);
Append (Buffer, ']'); Append (Buffer, ']');
when Kind_Map => when Kind_Map =>
Append (Buffer, '{'); Append (Buffer, '{');
Print_Map (Form_Ast.Map); Print_Map (Form_Ast.Map.all);
Append (Buffer, '}'); Append (Buffer, '}');
when Kind_Builtin | Kind_Builtin_With_Meta => when Kind_Builtin | Kind_Builtin_With_Meta =>
Append (Buffer, "#<built-in>"); Append (Buffer, "#<built-in>");
when Kind_Fn => when Kind_Fn =>
Append (Buffer, "#<function ("); Append (Buffer, "#<function (");
Print_Function (Form_Ast.Fn); Print_Function (Form_Ast.Fn.all);
Append (Buffer, '>'); Append (Buffer, '>');
when Kind_Macro => when Kind_Macro =>
Append (Buffer, "#<macro ("); Append (Buffer, "#<macro (");
Print_Function (Form_Ast.Fn); Print_Function (Form_Ast.Fn.all);
Append (Buffer, '>'); Append (Buffer, '>');
when Kind_Atom => when Kind_Atom =>
Append (Buffer, "(atom "); Append (Buffer, "(atom ");
Print_Form (Atoms.Deref (Form_Ast.Atom)); Print_Form (Form_Ast.Atom.all.Deref);
Append (Buffer, ')'); Append (Buffer, ')');
end case; end case;
end Print_Form; end Print_Form;
procedure Print_Function (Fn : in Fns.Ptr) is procedure Print_Function (Fn : in Fns.Instance) is
Started : Boolean := False; Started : Boolean := False;
begin begin
Append (Buffer, '('); Append (Buffer, '(');
@ -94,13 +94,13 @@ package body Printer is
else else
Started := True; Started := True;
end if; end if;
Append (Buffer, Param.To_String); Append (Buffer, Symbols.To_String (Param));
end loop; end loop;
Append (Buffer, ") -> "); Append (Buffer, ") -> ");
Print_Form (Fn.Ast); Print_Form (Fn.Ast);
end Print_Function; end Print_Function;
procedure Print_List (List : in Sequences.Ptr) is procedure Print_List (List : in Sequences.Instance) is
begin begin
if 0 < List.Length then if 0 < List.Length then
Print_Form (List (1)); Print_Form (List (1));
@ -111,7 +111,7 @@ package body Printer is
end if; end if;
end Print_List; 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; procedure Process (Key : in Mal.T;
Element : in Mal.T) with Inline; Element : in Mal.T) with Inline;
procedure Iterate is new Maps.Iterate (Process); 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 package body Reader is
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader"); Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread");
use Types; use Types;
use type Ada.Strings.Maps.Character_Set; use type Ada.Strings.Maps.Character_Set;
@ -37,7 +37,7 @@ package body Reader is
B_Last : Natural := Buffer'First - 1; B_Last : Natural := Buffer'First - 1;
-- Index in Buffer of the currently written MAL expression. -- Index in Buffer of the currently written MAL expression.
procedure Read_Form; function Read_Form return Mal.T;
-- The recursive part of Read_Str. -- The recursive part of Read_Str.
-- Helpers for Read_Form: -- Helpers for Read_Form:
@ -58,124 +58,127 @@ package body Reader is
-- Read_Atom has been merged into the same case/switch -- Read_Atom has been merged into the same case/switch
-- statement, for clarity and efficiency. -- statement, for clarity and efficiency.
procedure Read_List (Ending : in Character;
Constructor : in not null Mal.Builtin_Ptr) function Read_List (Ending : in Character) return Natural with Inline;
with Inline; -- Returns the index of the last elements in Buffer.
procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline; -- The elements have been stored in Buffer (B_Last .. result).
procedure Read_String with Inline;
procedure Read_With_Meta with Inline; 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; function Read_List (Ending : in Character) return Natural is
Constructor : in not null Mal.Builtin_Ptr) is
Opening : constant Character := Source (I); Opening : constant Character := Source (I);
B_First : constant Positive := B_Last; Old : constant Natural := B_Last;
Result : Positive;
begin begin
I := I + 1; -- Skip (, [ or {. I := I + 1; -- Skip (, [ or {.
loop loop
Skip_Ignored; Skip_Ignored;
Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'"); Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'");
exit when Source (I) = Ending; exit when Source (I) = Ending;
Read_Form;
B_Last := B_Last + 1; B_Last := B_Last + 1;
Buffer (B_Last) := Read_Form;
end loop; end loop;
I := I + 1; -- Skip ), ] or }. I := I + 1; -- Skip ), ] or }.
Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1)); Result := B_Last;
B_Last := B_First; B_Last := Old;
return Result;
end Read_List; 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 begin
Buffer (B_Last) := (Kind_Symbol, Symbol);
I := I + 1; -- Skip the initial ' or similar. I := I + 1; -- Skip the initial ' or similar.
R.Replace_Element (1, (Kind_Symbol, Symbol));
Skip_Ignored; Skip_Ignored;
Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'"); Err.Check (I <= Source'Last,
B_Last := B_Last + 1; "Incomplete '" & Symbols.To_String (Symbol) & "'");
Read_Form; R.Replace_Element (2, Read_Form);
B_Last := B_Last - 1; return (Kind_List, R);
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1));
end Read_Quote; end Read_Quote;
procedure Read_Form is function Read_Form return Mal.T is
-- After I has been increased, current token is be -- After I has been increased, current token is be
-- Source (F .. I - 1). -- Source (F .. I - 1).
F : Positive; F : Positive;
R : Mal.T; -- The result of this function.
begin begin
case Source (I) is case Source (I) is
when ')' | ']' | '}' => when ')' | ']' | '}' =>
Err.Raise_With ("unbalanced '" & Source (I) & "'"); Err.Raise_With ("unbalanced '" & Source (I) & "'");
when '"' => when '"' =>
Read_String; R := Read_String;
when ':' => when ':' =>
I := I + 1; I := I + 1;
F := I; F := I;
Skip_Symbol; Skip_Symbol;
Buffer (B_Last) := (Kind_Keyword, R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String
Ada.Strings.Unbounded.To_Unbounded_String (Source (F .. I - 1)));
(Source (F .. I - 1)));
when '-' => when '-' =>
F := I; F := I;
Skip_Digits; Skip_Digits;
if F + 1 < I then if F + 1 < I then
Buffer (B_Last) := (Kind_Number, R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
Integer'Value (Source (F .. I - 1)));
else else
Skip_Symbol; Skip_Symbol;
Buffer (B_Last) := (Kind_Symbol, R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1))); Symbols.Constructor (Source (F .. I - 1)));
end if; end if;
when '~' => when '~' =>
if I < Source'Last and then Source (I + 1) = '@' then if I < Source'Last and then Source (I + 1) = '@' then
I := I + 1; I := I + 1;
Read_Quote (Symbols.Names.Splice_Unquote); R := Read_Quote (Symbols.Names.Splice_Unquote);
else else
Read_Quote (Symbols.Names.Unquote); R := Read_Quote (Symbols.Names.Unquote);
end if; end if;
when '0' .. '9' => when '0' .. '9' =>
F := I; F := I;
Skip_Digits; Skip_Digits;
Buffer (B_Last) := (Kind_Number, R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
Integer'Value (Source (F .. I - 1)));
when ''' => when ''' =>
Read_Quote (Symbols.Names.Quote); R := Read_Quote (Symbols.Names.Quote);
when '`' => when '`' =>
Read_Quote (Symbols.Names.Quasiquote); R := Read_Quote (Symbols.Names.Quasiquote);
when '@' => when '@' =>
Read_Quote (Symbols.Names.Deref); R := Read_Quote (Symbols.Names.Deref);
when '^' => when '^' =>
Read_With_Meta; R := Read_With_Meta;
when '(' => when '(' =>
Read_List (')', Sequences.List'Access); R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')')));
when '[' => when '[' =>
Read_List (']', Sequences.Vector'Access); R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']')));
when '{' => when '{' =>
Read_List ('}', Maps.Hash_Map'Access); R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}')));
when others => when others =>
F := I; F := I;
Skip_Symbol; Skip_Symbol;
if Source (F .. I - 1) = "false" then if Source (F .. I - 1) = "false" then
Buffer (B_Last) := (Kind_Boolean, False); R := (Kind_Boolean, False);
elsif Source (F .. I - 1) = "nil" then elsif Source (F .. I - 1) = "nil" then
Buffer (B_Last) := Mal.Nil; R := Mal.Nil;
elsif Source (F .. I - 1) = "true" then elsif Source (F .. I - 1) = "true" then
Buffer (B_Last) := (Kind_Boolean, True); R := (Kind_Boolean, True);
else else
Buffer (B_Last) := (Kind_Symbol, R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1))); Symbols.Constructor (Source (F .. I - 1)));
end if; end if;
end case; end case;
if Debug then if Debug then
Ada.Text_IO.Put ("reader: "); Ada.Text_IO.Put ("reader: ");
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R));
(B_Last)));
end if; end if;
return R;
end Read_Form; end Read_Form;
procedure Read_String is function Read_String return Mal.T is
use Ada.Strings.Unbounded; use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin begin
Buffer (B_Last) := (Kind_String, Null_Unbounded_String);
loop loop
I := I + 1; I := I + 1;
Err.Check (I <= Source'Last, "unbalanced '""'"); Err.Check (I <= Source'Last, "unbalanced '""'");
@ -187,33 +190,31 @@ package body Reader is
Err.Check (I <= Source'Last, "unbalanced '""'"); Err.Check (I <= Source'Last, "unbalanced '""'");
case Source (I) is case Source (I) is
when '\' | '"' => when '\' | '"' =>
Append (Buffer (B_Last).S, Source (I)); Append (Result, Source (I));
when 'n' => when 'n' =>
Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF); Append (Result, Ada.Characters.Latin_1.LF);
when others => when others =>
Append (Buffer (B_Last).S, Source (I - 1 .. I)); Append (Result, Source (I - 1 .. I));
end case; end case;
when others => when others =>
Append (Buffer (B_Last).S, Source (I)); Append (Result, Source (I));
end case; end case;
end loop; end loop;
I := I + 1; -- Skip closing double quote. I := I + 1; -- Skip closing double quote.
return (Kind_String, Result);
end Read_String; 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 begin
I := I + 1; -- Skip the initial ^. 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; Skip_Ignored;
Err.Check (I <= Source'Last, "Incomplete 'with-meta'"); Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
Read_Form; List.all.Replace_Element (I, Read_Form);
B_Last := B_Last + 1;
end loop; end loop;
-- Replace (metadata data) with (with-meta data metadata). return (Kind_List, List);
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));
end Read_With_Meta; end Read_With_Meta;
procedure Skip_Digits is procedure Skip_Digits is
@ -259,7 +260,7 @@ package body Reader is
Skip_Ignored; Skip_Ignored;
exit when Source'Last < I; exit when Source'Last < I;
B_Last := B_Last + 1; B_Last := B_Last + 1;
Read_Form; Buffer (B_Last) := Read_Form;
end loop; end loop;
return Buffer (Buffer'First .. B_Last); return Buffer (Buffer'First .. B_Last);
end Read_Str; end Read_Str;

20
ada.2/step1_read_print.adb
View File

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

107
ada.2/step3_env.adb
View File

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

118
ada.2/step4_if_fn_do.adb
View File

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

125
ada.2/step5_tco.adb
View File

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

159
ada.2/step6_file.adb
View File

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

220
ada.2/step7_quote.adb
View File

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

251
ada.2/step8_macros.adb
View File

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

282
ada.2/step9_try.adb
View File

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

287
ada.2/stepa_mal.adb
View File

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

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

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

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

@ -1,10 +1,9 @@
private with Ada.Finalization; with Garbage_Collected;
with Types.Mal;
limited with Types.Mal;
package Types.Atoms is package Types.Atoms is
type Ptr is private; type Instance (<>) is new Garbage_Collected.Instance with private;
-- Built-in functions. -- Built-in functions.
function Atom (Args : in Mal.T_Array) return Mal.T; 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; function Swap (Args : in Mal.T_Array) return Mal.T;
-- Helper for print. -- Helper for print.
function Deref (Item : in Ptr) return Mal.T with Inline; function Deref (Item : in Instance) return Mal.T with Inline;
-- Debug.
procedure Check_Allocations;
private private
type Rec; type Instance is new Garbage_Collected.Instance with record
type Acc is access Rec; Data : Mal.T;
type Ptr is new Ada.Finalization.Controlled with record end record;
Ref : Acc := null; overriding procedure Keep_References (Object : in out Instance) with Inline;
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);
end Types.Atoms; 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 package body Types.Builtins is
type Rec is limited record function Builtin (Item : in Instance) return Mal.Builtin_Ptr
Builtin : Mal.Builtin_Ptr; is (Item.F_Builtin);
Refs : Natural;
Meta : Mal.T;
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); procedure Keep_References (Object : in out Instance) is
Allocations : Natural := 0;
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin begin
Object.Ref.all.Refs := @ + 1; Mal.Keep (Object.F_Meta);
end Adjust; end Keep_References;
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr function Meta (Item : in Instance) return Mal.T
is (Item.Ref.all.Builtin); is (Item.F_Meta);
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 With_Meta (Builtin : in Mal.Builtin_Ptr; 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 begin
Allocations := Allocations + 1; Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Builtin_With_Meta, return (Kind_Builtin_With_Meta, Ref);
(Ada.Finalization.Controlled with new Rec'(Builtin => Builtin,
Meta => Metadata,
Refs => 1)));
end With_Meta; end With_Meta;
function With_Meta (Item : in Ptr; function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T Metadata : in Mal.T) return Mal.T
-- Do not try to reuse the memory. We can hope that this kind of is (With_Meta (Item.Builtin, Metadata));
-- nonsense will be rare.
is (With_Meta (Item.Ref.all.Builtin, Metadata));
end Types.Builtins; end Types.Builtins;

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

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

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

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

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

@ -1,52 +1,48 @@
private with Ada.Finalization; with Envs;
with Garbage_Collected;
limited with Envs; with Types.Mal;
limited with Types.Mal; with Types.Sequences;
limited with Types.Sequences; with Types.Symbols;
limited with Types.Symbols;
package Types.Fns is 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. -- 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; Ast : in Mal.T;
Env : in Envs.Closure_Ptr) return Mal.T Env : in Envs.Ptr) return Mal.T
with Inline; with Inline;
-- Raise an exception if Params contains something else than symbols. -- 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 Params (Item : in Instance) return Symbols.Symbol_Array
function Ast (Item : in Ptr) return Mal.T with Inline; with Inline;
function Ast (Item : in Instance) return Mal.T with Inline;
-- Useful to print. -- Useful to print.
function Apply (Item : in Ptr; function Apply (Item : in Instance;
Args : in Mal.T_Array) return Mal.T with Inline; 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; function Env (Item : in Instance) return Envs.Ptr with Inline;
-- Fails for macros. Required for TCO, instead of Apply. -- Returns null for macros.
-- Required for TCO, instead of Apply.
function Meta (Item : in Ptr) return Mal.T with Inline; function Meta (Item : in Instance) return Mal.T with Inline;
-- Fails for macros. function With_Meta (Item : in Instance;
function With_Meta (Item : in Ptr;
Metadata : in Mal.T) return Mal.T with Inline; Metadata : in Mal.T) return Mal.T with Inline;
-- Fails for macros.
procedure Check_Allocations;
private private
type Rec; type Instance (Last : Natural) is new Garbage_Collected.Instance
type Acc is access Rec; with record
type Ptr is new Ada.Finalization.Controlled with record F_Ast : Mal.T;
Ref : Acc := null; F_Env : Envs.Ptr;
end record F_Meta : Mal.T;
with Invariant => Ptr.Ref /= null; F_Params : Symbols.Symbol_Array (1 .. Last);
overriding procedure Adjust (Object : in out Ptr) with Inline; end record;
overriding procedure Finalize (Object : in out Ptr) with Inline; overriding procedure Keep_References (Object : in out Instance) with Inline;
pragma Finalize_Storage_Only (Ptr);
end Types.Fns; 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 package body Types.Mal is
use type Ada.Strings.Unbounded.Unbounded_String; use type Ada.Strings.Unbounded.Unbounded_String;
use type Maps.Ptr; use type Maps.Instance;
use type Sequences.Ptr; use type Sequences.Instance;
use type Symbols.Ptr; use type Symbols.Ptr;
---------------------------------------------------------------------- ----------------------------------------------------------------------
@ -22,11 +28,31 @@ package body Types.Mal is
Right.Kind = Left.Kind and then Left.S = Right.S, Right.Kind = Left.Kind and then Left.S = Right.S,
-- Here comes the part that differs from the predefined equality. -- Here comes the part that differs from the predefined equality.
when Kind_Sequence => 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 => 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. -- Also, comparing functions is an interesting problem.
when others => when others =>
False); 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; end Types.Mal;

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

@ -1,10 +1,10 @@
with Ada.Strings.Unbounded; with Ada.Strings.Unbounded;
with Types.Atoms; limited with Types.Atoms;
with Types.Builtins; limited with Types.Builtins;
with Types.Fns; limited with Types.Fns;
with Types.Maps; limited with Types.Maps;
with Types.Sequences; limited with Types.Sequences;
with Types.Symbols; with Types.Symbols;
package Types.Mal is package Types.Mal is
@ -48,7 +48,13 @@ package Types.Mal is
type T; type T;
type T_Array; type T_Array;
type Atom_Ptr is access Atoms.Instance;
type Builtin_Ptr is access function (Args : in T_Array) return T; 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 type T (Kind : Kind_Type := Kind_Nil) is record
case Kind is case Kind is
@ -59,21 +65,21 @@ package Types.Mal is
when Kind_Number => when Kind_Number =>
Number : Integer; Number : Integer;
when Kind_Atom => when Kind_Atom =>
Atom : Atoms.Ptr; Atom : Atom_Ptr;
when Kind_Key => when Kind_Key =>
S : Ada.Strings.Unbounded.Unbounded_String; S : Ada.Strings.Unbounded.Unbounded_String;
when Kind_Symbol => when Kind_Symbol =>
Symbol : Symbols.Ptr; Symbol : Symbols.Ptr;
when Kind_Sequence => when Kind_Sequence =>
Sequence : Sequences.Ptr; Sequence : Sequence_Ptr;
when Kind_Map => when Kind_Map =>
Map : Maps.Ptr; Map : Map_Ptr;
when Kind_Builtin => when Kind_Builtin =>
Builtin : Builtin_Ptr; Builtin : Builtin_Ptr;
when Kind_Builtin_With_Meta => when Kind_Builtin_With_Meta =>
Builtin_With_Meta : Builtins.Ptr; Builtin_With_Meta : Builtin_With_Meta_Ptr;
when Kind_Fn | Kind_Macro => when Kind_Fn | Kind_Macro =>
Fn : Fns.Ptr; Fn : Fn_Ptr;
end case; end case;
end record; end record;
@ -83,6 +89,8 @@ package Types.Mal is
Nil : constant T := (Kind => Kind_Nil); Nil : constant T := (Kind => Kind_Nil);
procedure Keep (Object : in Mal.T) with Inline;
type T_Array is array (Positive range <>) of T; type T_Array is array (Positive range <>) of T;
end Types.Mal; 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.Strings.Unbounded.Hash;
with Ada.Unchecked_Deallocation;
with Err; with Err;
with Types.Sequences; with Types.Sequences;
with Types.Mal;
package body Types.Maps is package body Types.Maps is
subtype AFC is Ada.Finalization.Controlled; function Constructor return Mal.Map_Ptr with Inline;
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 "=" (Left, Right : in Ptr) return Boolean function "=" (Left, Right : in Instance) return Boolean
is (Left.Ref.all.Data = Right.Ref.all.Data); is (Left.Data = Right.Data);
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := @ + 1;
end Adjust;
function Assoc (Args : in Mal.T_Array) return Mal.T is function Assoc (Args : in Mal.T_Array) return Mal.T is
Ref : Acc; Ref : constant Mal.Map_Ptr := Constructor;
begin begin
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count"); Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
Err.Check (Args (Args'First).Kind = Kind_Map, Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map"); "parameter 1 must be a map");
-- Avoid exceptions until Ref is controlled. Ref.all.Data := Args (Args'First).Map.all.Data;
Ref := Args (Args'First).Map.Ref; for I in 1 .. Args'Length / 2 loop
pragma Assert (0 < Ref.all.Refs); Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
if Ref.all.Refs = 1 then New_Item => Args (Args'First + 2 * I));
Ref.all.Refs := 2; -- This call checks the kind of the key.
Ref.all.Meta := Mal.Nil; end loop;
else return (Kind_Map, Ref);
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;
end Assoc; 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 function Contains (Args : in Mal.T_Array) return Mal.T is
begin begin
Err.Check (Args'Length = 2, "expected 2 parameters"); Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Map, Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map"); "parameter 1 must be a map");
return (Kind_Boolean, 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; 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 function Dissoc (Args : in Mal.T_Array) return Mal.T is
Ref : Acc; Ref : constant Mal.Map_Ptr := Constructor;
begin begin
Err.Check (0 < Args'Length, "expected at least 1 parameter"); Err.Check (0 < Args'Length, "expected at least 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map, Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map"); "parameter 1 must be a map");
-- Avoid exceptions until Ref is controlled. Ref.all.Data := Args (Args'First).Map.all.Data;
Ref := Args (Args'First).Map.Ref; for I in Args'First + 1 .. Args'Last loop
pragma Assert (0 < Ref.all.Refs); Ref.all.Data.Exclude (Args (I));
if Ref.all.Refs = 1 then -- This call checks the kind of the key.
Ref.all.Refs := 2; end loop;
Ref.all.Meta := Mal.Nil; return (Kind_Map, Ref);
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;
end Dissoc; end Dissoc;
procedure Finalize (Object : in out Ptr) is function Generic_Eval (Container : in Instance;
begin Env : in Env_Type) return Mal.T
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
is is
-- Copy the whole hash in order to avoid recomputing the hash -- Copy the whole hash in order to avoid recomputing the hash
-- for each key, even if it implies unneeded calls to adjust -- for each key, even if it implies unneeded calls to adjust
-- and finalize for Mal_Type values. -- and finalize for Mal_Type values.
-- Avoid exceptions until Ref is controlled. Ref : constant Mal.Map_Ptr := Constructor;
Ref : Acc := Container.Ref;
begin begin
pragma Assert (0 < Ref.all.Refs); Ref.Data := Container.Data;
if Ref.all.Refs = 1 then for Position in Ref.all.Data.Iterate loop
Ref.all.Refs := 2; Ref.all.Data.Replace_Element (Position,
Ref.all.Meta := Mal.Nil; Eval (HM.Element (Position), Env));
else -- This call may raise exceptions.
Allocations := Allocations + 1; end loop;
Ref := new Rec'(Data => Ref.all.Data, return Mal.T'(Kind_Map, Ref);
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;
end Generic_Eval; end Generic_Eval;
function Get (Args : in Mal.T_Array) return Mal.T is 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"); "key must be a keyword or string");
return Mal.Nil; return Mal.Nil;
when Kind_Map => when Kind_Map =>
Position Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last));
:= Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last));
-- This call checks the kind of the key. -- This call checks the kind of the key.
if HM.Has_Element (Position) then if HM.Has_Element (Position) then
return HM.Element (Position); 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 function Hash_Map (Args : in Mal.T_Array) return Mal.T is
Binds : constant Natural := Args'Length / 2; Binds : constant Natural := Args'Length / 2;
Ref : Acc; Ref : Mal.Map_Ptr;
begin begin
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count"); Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
Allocations := Allocations + 1; Ref := Constructor;
-- Avoid exceptions until Ref is controlled.
Ref := new Rec;
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds)); 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
for I in 0 .. Binds - 1 loop Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
Ref.all.Data.Include (Key => Args (Args'First + 2 * I), New_Item => Args (Args'First + 2 * I + 1));
New_Item => Args (Args'First + 2 * I + 1)); -- This call checks the kind of the key.
-- This call checks the kind of the key. end loop;
end loop; return (Kind_Map, Ref);
end return;
end Hash_Map; end Hash_Map;
procedure Iterate (Container : in Ptr) is procedure Iterate (Container : in Instance) is
begin begin
for Position in Container.Ref.all.Data.Iterate loop for Position in Container.Data.Iterate loop
Process (HM.Key (Position), HM.Element (Position)); Process (HM.Key (Position), HM.Element (Position));
end loop; end loop;
end Iterate; 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 function Keys (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map, Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map"); "parameter 1 must be a map");
declare A1 := Args (Args'First).Map;
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; R := Sequences.Constructor (A1.all.Length);
R : Mal.T_Array (1 .. Natural (A1.Length)); for Position in A1.all.Data.Iterate loop
I : Positive := 1; R.all.Replace_Element (I, HM.Key (Position));
begin I := I + 1;
for Position in A1.Iterate loop end loop;
R (I) := HM.Key (Position); return (Kind_List, R);
I := I + 1;
end loop;
return Sequences.List (R);
end;
end Keys; end Keys;
function Meta (Container : in Ptr) return Mal.T function Length (Container : in Instance) return Natural
is (Container.Ref.all.Meta); 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 function Vals (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map, Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map"); "parameter 1 must be a map");
declare A1 := Args (Args'First).Map;
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data; R := Sequences.Constructor (A1.all.Length);
R : Mal.T_Array (1 .. Natural (A1.Length)); for Element of A1.all.Data loop
I : Positive := 1; R.all.Replace_Element (I, Element);
begin I := I + 1;
for Element of A1 loop end loop;
R (I) := Element; return (Kind_List, R);
I := I + 1;
end loop;
return Sequences.List (R);
end;
end Vals; end Vals;
function With_Meta (Data : in Ptr; function With_Meta (Data : in Instance;
Metadata : in Mal.T) Metadata : in Mal.T) return Mal.T
return Mal.T
is is
-- Avoid exceptions until Ref is controlled. Ref : constant Mal.Map_Ptr := Constructor;
Ref : Acc := Data.Ref;
begin begin
pragma Assert (0 < Ref.all.Refs); Ref.all.Data := Data.Data;
if Ref.all.Refs = 1 then Ref.all.F_Meta := Metadata;
Ref.all.Refs := 2; return (Kind_Map, Ref);
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));
end With_Meta; end With_Meta;
end Types.Maps; 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 package Types.Maps is
type Ptr is tagged private; type Instance (<>) is new Garbage_Collected.Instance with private;
-- Built-in functions. -- Built-in functions.
function Assoc (Args : in Mal.T_Array) return Mal.T; 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 Keys (Args : in Mal.T_Array) return Mal.T;
function Vals (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 -- A generic is better than an access to function because of
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159 -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
-- Used to evaluate each element of a map. -- Used to evaluate each element of a map.
-- Eval is generic because units cannot depend on each other.
generic generic
type Env_Type (<>) is limited private; type Env_Type (<>) is limited private;
with function Eval (Ast : in Mal.T; with function Eval (Ast : in Mal.T;
Env : in Env_Type) Env : in Env_Type)
return Mal.T; return Mal.T;
function Generic_Eval (Container : in Ptr; function Generic_Eval (Container : in Instance;
Env : in Env_Type) Env : in Env_Type)
return Mal.T; return Mal.T;
@ -33,28 +36,32 @@ package Types.Maps is
generic generic
with procedure Process (Key : in Mal.T; with procedure Process (Key : in Mal.T;
Element : 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) Metadata : in Mal.T)
return Mal.T; return Mal.T;
-- Debug
procedure Check_Allocations;
private private
type Rec; function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline;
type Acc is access Rec; -- This function also checks the kind of the key, and raise an
type Ptr is new Ada.Finalization.Controlled with record -- error in case of problem.
Ref : Acc := null;
end record package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
with Invariant => Ptr.Ref /= null; Element_Type => Mal.T,
overriding procedure Adjust (Object : in out Ptr) with Inline; Hash => Hash,
overriding procedure Finalize (Object : in out Ptr) with Inline; Equivalent_Keys => Mal."=",
overriding function "=" (Left, Right : in Ptr) return Boolean with Inline; "=" => Mal."=");
pragma Finalize_Storage_Only (Ptr); 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; end Types.Maps;

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

@ -1,68 +1,44 @@
with Ada.Unchecked_Deallocation;
with Err; with Err;
with Types.Mal; with Types.Builtins;
with Types.Fns;
package body Types.Sequences is package body Types.Sequences is
subtype AFC is Ada.Finalization.Controlled;
use type Mal.T_Array; 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 -- Should become Left.Ref.all.Data = Right.Ref.all.Data when
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed. -- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
use type Mal.T; use type Mal.T;
L : Rec renames Left.Ref.all;
R : Rec renames Right.Ref.all;
begin begin
return L.Last = R.Last return Left.Last = Right.Last
and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I)); and then
(for all I in 1 .. Left.Last => Left.Data (I) = Right.Data (I));
end "="; end "=";
function "&" (Left : in Mal.T_Array; function "&" (Left : in Mal.T_Array;
Right : in Ptr) return Mal.T_Array Right : in Instance) return Mal.T_Array
is (Left & Right.Ref.all.Data); is (Left & Right.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;
function Concat (Args : in Mal.T_Array) return Mal.T is function Concat (Args : in Mal.T_Array) return Mal.T is
Sum : Natural := 0; Sum : Natural := 0;
First : Positive := 1; First : Positive := 1;
Last : Natural; Last : Natural;
Ref : Acc; Ref : Mal.Sequence_Ptr;
begin begin
for Arg of Args loop for Arg of Args loop
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences"); 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; end loop;
Allocations := Allocations + 1; Ref := Constructor (Sum);
-- Avoid exceptions until Ref is controlled.
Ref := new Rec (Sum);
for Arg of Args loop for Arg of Args loop
Last := First - 1 + Arg.Sequence.Ref.all.Data'Length; Last := First - 1 + Arg.Sequence.all.Data'Length;
Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data; Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
First := Last + 1; First := Last + 1;
end loop; end loop;
return (Kind_List, (AFC with Ref)); return (Kind_List, Ref);
end Concat; end Concat;
function Conj (Args : in Mal.T_Array) return Mal.T is 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 case Args (Args'First).Kind is
when Kind_Sequence => when Kind_Sequence =>
declare 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; Last : constant Natural := Args'Length - 1 + Data'Length;
-- Avoid exceptions until Ref is controlled. -- Avoid exceptions until Ref is controlled.
Ref : constant Acc := new Rec (Last); Ref : constant Mal.Sequence_Ptr := Constructor (Last);
begin begin
Allocations := Allocations + 1;
if Args (Args'First).Kind = Kind_List then if Args (Args'First).Kind = Kind_List then
for I in 1 .. Args'Length - 1 loop for I in 1 .. Args'Length - 1 loop
Ref.all.Data (I) := Args (Args'Last - I + 1); Ref.all.Data (I) := Args (Args'Last - I + 1);
end loop; end loop;
Ref.all.Data (Args'Length .. Last) := Data; Ref.all.Data (Args'Length .. Last) := Data;
return (Kind_List, (AFC with Ref)); return (Kind_List, Ref);
else else
Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last); Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
return (Kind_Vector, (AFC with Ref)); return (Kind_Vector, Ref);
end if; end if;
end; end;
when others => when others =>
@ -100,15 +75,21 @@ package body Types.Sequences is
"parameter 2 must be a sequence"); "parameter 2 must be a sequence");
declare declare
Head : Mal.T renames Args (Args'First); 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 begin
Allocations := Allocations + 1; Ref.all.Data := Head & Tail;
return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length, return (Kind_List, Ref);
Data => Head & Tail,
others => <>)));
end; end;
end Cons; 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 function Count (Args : in Mal.T_Array) return Mal.T is
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
@ -116,28 +97,15 @@ package body Types.Sequences is
when Kind_Nil => when Kind_Nil =>
return (Kind_Number, 0); return (Kind_Number, 0);
when Kind_Sequence => 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 => when others =>
Err.Raise_With ("parameter must be nil or a sequence"); Err.Raise_With ("parameter must be nil or a sequence");
end case; end case;
end Count; end Count;
function Element (Container : in Ptr; function Element (Container : in Instance;
Index : in Positive) return Mal.T Index : in Positive) return Mal.T
is (Container.Ref.all.Data (Index)); is (Container.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;
function First (Args : in Mal.T_Array) return Mal.T is function First (Args : in Mal.T_Array) return Mal.T is
begin begin
@ -147,7 +115,7 @@ package body Types.Sequences is
return Mal.Nil; return Mal.Nil;
when Kind_Sequence => when Kind_Sequence =>
declare 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 begin
if Data'Length = 0 then if Data'Length = 0 then
return Mal.Nil; return Mal.Nil;
@ -160,48 +128,30 @@ package body Types.Sequences is
end case; end case;
end First; 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 function Is_Empty (Args : in Mal.T_Array) return Mal.T is
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind in Kind_Sequence, Err.Check (Args (Args'First).Kind in Kind_Sequence,
"parameter must be a sequence"); "parameter must be a sequence");
return (Kind_Boolean, return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
Args (Args'First).Sequence.Ref.all.Data'Length = 0);
end Is_Empty; end Is_Empty;
function Length (Source : in Ptr) return Natural procedure Keep_References (Object : in out Instance) is
is (Source.Ref.all.Data'Length); 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 function List (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
begin begin
Allocations := Allocations + 1; Ref.all.Data := Args;
return (Kind_List, (AFC with new Rec'(Data => Args, return (Kind_List, Ref);
Last => Args'Length,
others => <>)));
end List; end List;
function Map (Args : in Mal.T_Array) return Mal.T is 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"); "parameter 2 must be a sequence");
declare declare
F : Mal.T renames Args (Args'First); F : Mal.T renames Args (Args'First);
Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data; Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
-- Avoid exceptions until Ref is controlled. Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length);
Ref : Acc := Args (Args'Last).Sequence.Ref;
begin begin
pragma Assert (0 < Ref.all.Refs); case F.Kind is
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
when Kind_Builtin => when Kind_Builtin =>
for I in Src'Range loop for I in Src'Range loop
Ref.all.Data (I) := F.Builtin.all (Src (I .. I)); 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; end loop;
when Kind_Builtin_With_Meta => when Kind_Builtin_With_Meta =>
for I in Src'Range loop for I in Src'Range loop
Ref.all.Data (I) 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; end loop;
when Kind_Fn => when Kind_Fn =>
for I in Src'Range loop 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; end loop;
when others => when others =>
Err.Raise_With ("parameter 1 must be a function"); Err.Raise_With ("parameter 1 must be a function");
end case; end case;
end return; return (Kind_List, Ref);
end; end;
end Map; end Map;
function Meta (Item : in Ptr) return Mal.T function Meta (Item : in Instance) return Mal.T
is (Item.Ref.all.Meta); is (Item.F_Meta);
function Nth (Args : in Mal.T_Array) return Mal.T is function Nth (Args : in Mal.T_Array) return Mal.T is
begin begin
@ -258,7 +196,7 @@ package body Types.Sequences is
Err.Check (Args (Args'Last).Kind = Kind_Number, Err.Check (Args (Args'Last).Kind = Kind_Number,
"parameter 2 must be a number"); "parameter 2 must be a number");
declare 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; I : constant Integer := Args (Args'Last).Number + 1;
begin begin
Err.Check (I in L'Range, "index out of bounds"); Err.Check (I in L'Range, "index out of bounds");
@ -266,70 +204,62 @@ package body Types.Sequences is
end; end;
end Nth; 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 function Rest (Args : in Mal.T_Array) return Mal.T is
begin begin
Err.Check (Args'Length = 1, "expected 1 parameter"); Err.Check (Args'Length = 1, "expected 1 parameter");
declare declare
A1 : Mal.T renames Args (Args'First); A1 : Mal.T renames Args (Args'First);
Ref : Acc; Ref : Mal.Sequence_Ptr;
begin begin
-- Avoid exceptions until Ref is controlled. -- Avoid exceptions until Ref is controlled.
case A1.Kind is case A1.Kind is
when Kind_Nil => when Kind_Nil =>
Allocations := Allocations + 1; Ref := Constructor (0);
Ref := new Rec (0);
when Kind_Sequence => when Kind_Sequence =>
Allocations := Allocations + 1; if A1.Sequence.all.Last = 0 then
if A1.Sequence.Ref.all.Last = 0 then Ref := Constructor (0);
Ref := new Rec (0);
else else
Ref := new Rec' Ref := Constructor (A1.Sequence.all.Last - 1);
(Last => A1.Sequence.Ref.all.Last - 1, Ref.all.Data
Data => A1.Sequence.Ref.all.Data := A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last);
(2 .. A1.Sequence.Ref.all.Data'Last),
others => <>);
end if; end if;
when others => when others =>
Err.Raise_With ("parameter must be nil or a sequence"); Err.Raise_With ("parameter must be nil or a sequence");
end case; end case;
return (Kind_List, (AFC with Ref)); return (Kind_List, Ref);
end; end;
end Rest; end Rest;
function Tail (Source : in Ptr; function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array is 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 begin
return Data (Data'Last - Count + 1 .. Data'Last); return Data (Data'Last - Count + 1 .. Data'Last);
end Tail; end Tail;
function Vector (Args : in Mal.T_Array) return Mal.T is function Vector (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
begin begin
Allocations := Allocations + 1; Ref.all.Data := Args;
return (Kind_Vector, (AFC with new Rec'(Data => Args, return (Kind_Vector, Ref);
Last => Args'Length,
others => <>)));
end Vector; end Vector;
function With_Meta (Data : in Ptr; function With_Meta (Data : in Instance;
Metadata : in Mal.T) return Ptr Metadata : in Mal.T) return Mal.Sequence_Ptr
is is
-- Avoid exceptions until Ref is controlled. Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last);
Ref : Acc := Data.Ref;
begin begin
pragma Assert (0 < Ref.all.Refs); Ref.all.Data := Data.Data;
if Ref.all.Refs = 1 then Ref.all.F_Meta := Metadata;
Ref.all.Refs := 2; return Ref;
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);
end With_Meta; end With_Meta;
end Types.Sequences; end Types.Sequences;

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

@ -1,10 +1,9 @@
private with Ada.Finalization; with Garbage_Collected;
with Types.Mal;
limited with Types.Mal;
package Types.Sequences is package Types.Sequences is
type Ptr is tagged private type Instance (<>) is new Garbage_Collected.Instance with private
with Constant_Indexing => Element; with Constant_Indexing => Element;
-- Built-in functions. -- Built-in functions.
@ -20,59 +19,41 @@ package Types.Sequences is
function Rest (Args : in Mal.T_Array) return Mal.T; function Rest (Args : in Mal.T_Array) return Mal.T;
function Vector (Args : in Mal.T_Array) return Mal.T; function 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 Index : in Positive) return Mal.T
with Inline, Pre => Index <= Length (Container); with Inline, Pre => Index <= Length (Container);
function "&" (Left : in Mal.T_Array; 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 implement Core.Apply.
-- Used to evaluate each element of a list/vector. function Constructor (Length : in Natural) return Mal.Sequence_Ptr
-- Eval is generic because units cannot depend on each other. with Inline;
generic procedure Replace_Element (Container : in out Instance;
type Env_Type (<>) is limited private; Index : in Positive;
with function Eval (Ast : in Mal.T; New_Item : in Mal.T)
Env : in Env_Type) with Inline, Pre => Index <= Length (Container);
return Mal.T;
function Generic_Eval (Container : in Ptr;
Env : in Env_Type)
return Ptr;
-- Used in macro implementation. -- Used in macro implementation.
function Tail (Source : in Ptr; function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array Count : in Natural) return Mal.T_Array
with Inline, Pre => Count <= Length (Source); with Inline, Pre => Count <= Length (Source);
function Meta (Item : in Ptr) return Mal.T with Inline; function Meta (Item : in Instance) return Mal.T with Inline;
function With_Meta (Data : in Ptr; function With_Meta (Data : in Instance;
Metadata : in Mal.T) Metadata : in Mal.T)
return Ptr; return Mal.Sequence_Ptr;
-- Debug.
procedure Check_Allocations;
private private
-- It is tempting to use null to represent an empty list, but the type Instance (Last : Natural) is new Garbage_Collected.Instance with record
-- performance is not improved much, and the code is more complex. F_Meta : Mal.T;
-- In addition, the empty list may want to carry metadata. Data : Mal.T_Array (1 .. Last);
end record;
-- Similarly, always providing a default value like a pointer to a overriding procedure Keep_References (Object : in out Instance) with Inline;
-- 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);
end Types.Sequences; 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.Strings.Hash;
with Ada.Unchecked_Deallocation; with Ada.Unchecked_Deallocation;
package body Types.Symbols is 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 type Rec (Last : Positive) is limited record
Refs : Natural; Refs : Natural;
Hash : Ada.Containers.Hash_Type;
Data : String (1 .. Last); Data : String (1 .. Last);
end record; end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc); procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
Allocations : Natural := 0; Allocations : Natural := 0;
function "<" (Left, Right : in Acc) return Boolean with Inline; function Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline;
function Eq (Left, Right : in Acc) return Boolean with Inline; package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc,
-- It would be unwise to name this function "=" and override the Hash => Hash,
-- predefined equality for Acc. Equivalent_Elements => "=",
-- We only search by key and insert new elements, so this should "=" => "=");
-- always return False.
package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc,
"<" => "<",
"=" => Eq);
function Key (Item : in Acc) return String with Inline; function Key (Item : in Acc) return String with Inline;
package Keys is new Sets.Generic_Keys (Key_Type => String, package Keys is new Sets.Generic_Keys (Key_Type => String,
Key => Key, Key => Key,
"<" => Standard."<"); Hash => Ada.Strings.Hash,
Equivalent_Keys => "=");
Dict : Sets.Set; Dict : Sets.Set;
---------------------------------------------------------------------- ----------------------------------------------------------------------
function "<" (Left, Right : in Acc) return Boolean
is (Left.all.Data < Right.all.Data);
procedure Adjust (Object : in out Ptr) is procedure Adjust (Object : in out Ptr) is
begin begin
Object.Ref.all.Refs := @ + 1; Object.Ref.all.Refs := @ + 1;
@ -59,7 +48,6 @@ package body Types.Symbols is
else else
Allocations := Allocations + 1; Allocations := Allocations + 1;
Ref := new Rec'(Data => Source, Ref := new Rec'(Data => Source,
Hash => Ada.Strings.Hash (Source),
Last => Source'Length, Last => Source'Length,
Refs => 1); Refs => 1);
Dict.Insert (Ref); Dict.Insert (Ref);
@ -67,13 +55,6 @@ package body Types.Symbols is
return (Ada.Finalization.Controlled with Ref); return (Ada.Finalization.Controlled with Ref);
end Constructor; 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 procedure Finalize (Object : in out Ptr) is
begin begin
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
@ -88,8 +69,11 @@ package body Types.Symbols is
end if; end if;
end Finalize; 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 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 function Key (Item : in Acc) return String
is (Item.all.Data); 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 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; type Ptr is tagged private;
function Constructor (Source : in String) return Ptr with Inline; 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. -- probability to end up as keys in an environment.
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline; 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. -- Debug.
procedure Check_Allocations; procedure Check_Allocations with Inline;
-- Does nothing if assertions are disabled.
private private
@ -49,4 +59,9 @@ private
-- Predefined equality is fine. -- Predefined equality is fine.
pragma Finalize_Storage_Only (Ptr); 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; end Types.Symbols;