mirror of
https://github.com/kanaka/mal.git
synced 2024-09-21 02:27:10 +03:00
Merge pull request #348 from asarhaddon/ada.2
ada.2: fix memory leaks with garbage collection. Various simplifications.
This commit is contained in:
commit
15b8d6aa9d
@ -37,6 +37,7 @@ TYPES := \
|
||||
envs.ads envs.adb \
|
||||
err.ads err.adb \
|
||||
eval_cb.ads \
|
||||
garbage_collected.ads garbage_collected.adb \
|
||||
printer.ads printer.adb \
|
||||
reader.ads reader.adb \
|
||||
readline.ads \
|
||||
|
37
ada.2/README
37
ada.2/README
@ -14,19 +14,19 @@ but also two crucial performance improvements:
|
||||
* Lists are implemented as C-style arrays, and most of them can be
|
||||
allocated on the stack.
|
||||
|
||||
Once each component has an explicit interface, various optimizations
|
||||
have been added: unique allocation of symbols, stack-style allocation
|
||||
of environments in the current execution path, reuse of allocated
|
||||
memory when the reference count reaches 1...
|
||||
Another difference is that a minimal form of garbage collecting is
|
||||
implemented, removing objects not referenced from the main
|
||||
environment. Reference counting is convenient for symbols or strings,
|
||||
but never deallocates cyclic structures. The implementation collects
|
||||
garbage after each Read-Eval-Print cycle. It would be much more
|
||||
difficult to collect garbage inside scripts. If this is ever done, it
|
||||
would be better to reimplement load-file in Ada and run a cycle after
|
||||
each root evaluation.
|
||||
|
||||
The eventual performances compete with C-style languages, allthough
|
||||
all user input is checked (implicit language-defined checks like array
|
||||
bounds and discriminant consistency are only enabled during tests).
|
||||
|
||||
There are also similarities with the first implementation. For
|
||||
example, both rely on user-defined finalization to count references in
|
||||
recursive structures instead of a posteriori garbage collection.
|
||||
|
||||
Notes for contributors that do not fit in a specific package.
|
||||
--
|
||||
|
||||
@ -35,24 +35,29 @@ Notes for contributors that do not fit in a specific package.
|
||||
ensuring a valid value during elaboration.
|
||||
Note that generic packages cannot export access values.
|
||||
|
||||
* All wrapped pointers are non null, new variables must be assigned
|
||||
* Symbol pointers are non null, new variables must be assigned
|
||||
immediately. This is usually enforced by a hidden discriminant, but
|
||||
here we want the type to become a field inside Types.Mal.T. So the
|
||||
check happens at run time with a private invariant.
|
||||
|
||||
* The finalize procedure may be called twice, so it does nothing when
|
||||
The finalize procedure may be called twice, so it does nothing when
|
||||
the reference count is zero, meaning that we are reaching Finalize
|
||||
recursively.
|
||||
|
||||
* In implementations, a consistent object (that will be deallocated
|
||||
automatically) must be built before any exception is raised by user
|
||||
code (for example the 'map' built-in function may run user code).
|
||||
* In implementations with reference counting, a consistent object
|
||||
(that will be deallocated automatically) must be built before any
|
||||
exception is raised by user code (for example the 'map' built-in
|
||||
function may run user code). Garbage collection simplifies a lot
|
||||
this kind of situations.
|
||||
|
||||
* Each module encapsulating dynamic allocation counts allocations and
|
||||
deallocations. With debugging options, a failure is reported if
|
||||
- too many deallocation happen (via a numeric range check)
|
||||
- all storage is not freed (via a dedicated call from the step file)
|
||||
|
||||
The main program only checks that the garbage collector removes all
|
||||
allocations at the end of execution.
|
||||
|
||||
Debugging
|
||||
--
|
||||
|
||||
@ -61,7 +66,5 @@ TCO cycles). This has become possible in step9, but has been
|
||||
backported to former steps as this is really handy for debugging.
|
||||
|
||||
Some environment variables increase verbosity.
|
||||
# dbg_reader= ./stepAmal trace reader recursion
|
||||
# dbgeval= ./stepAmal eval recursion (or TCO)
|
||||
# dbgenv0= ./stepAmal eval recursion and environments contents
|
||||
# dbgenv1= ./stepAmal eval recursion and environment internals
|
||||
# dbgread= ./stepAmal trace reader recursion
|
||||
# dbgeval= ./stepAmal trace eval recursion (including TCO)
|
||||
|
@ -3,11 +3,10 @@ with Ada.Characters.Latin_1;
|
||||
with Ada.Strings.Unbounded;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
@ -64,7 +63,6 @@ package body Core is
|
||||
function Apply (Args : in Mal.T_Array) return Mal.T;
|
||||
function Division is new Generic_Mal_Operator ("/");
|
||||
function Equals (Args : in Mal.T_Array) return Mal.T;
|
||||
function Eval (Args : in Mal.T_Array) return Mal.T;
|
||||
function Greater_Equal is new Generic_Comparison (">=");
|
||||
function Greater_Than is new Generic_Comparison (">");
|
||||
function Is_Atom is new Generic_Kind_Test (Kind_Atom);
|
||||
@ -108,19 +106,19 @@ package body Core is
|
||||
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
|
||||
"last parameter must be a sequence");
|
||||
declare
|
||||
use type Sequences.Ptr;
|
||||
use type Sequences.Instance;
|
||||
F : Mal.T renames Args (Args'First);
|
||||
A : constant Mal.T_Array
|
||||
:= Args (Args'First + 1 .. Args'Last - 1)
|
||||
& Args (Args'Last).Sequence;
|
||||
& Args (Args'Last).Sequence.all;
|
||||
begin
|
||||
case F.Kind is
|
||||
when Kind_Builtin =>
|
||||
return F.Builtin.all (A);
|
||||
when Kind_Builtin_With_Meta =>
|
||||
return F.Builtin_With_Meta.Builtin.all (A);
|
||||
return F.Builtin_With_Meta.all.Builtin.all (A);
|
||||
when Kind_Fn =>
|
||||
return F.Fn.Apply (A);
|
||||
return F.Fn.all.Apply (A);
|
||||
when others =>
|
||||
Err.Raise_With ("parameter 1 must be a function");
|
||||
end case;
|
||||
@ -134,13 +132,6 @@ package body Core is
|
||||
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
|
||||
end Equals;
|
||||
|
||||
function Eval (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Ast => Args (Args'First),
|
||||
Env => Envs.Repl);
|
||||
end Eval;
|
||||
|
||||
function Is_False (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
@ -188,13 +179,13 @@ package body Core is
|
||||
begin
|
||||
case A1.Kind is
|
||||
when Kind_Sequence =>
|
||||
return A1.Sequence.Meta;
|
||||
return A1.Sequence.all.Meta;
|
||||
when Kind_Map =>
|
||||
return A1.Map.Meta;
|
||||
return A1.Map.all.Meta;
|
||||
when Kind_Fn =>
|
||||
return A1.Fn.Meta;
|
||||
return A1.Fn.all.Meta;
|
||||
when Kind_Builtin_With_Meta =>
|
||||
return A1.Builtin_With_Meta.Meta;
|
||||
return A1.Builtin_With_Meta.all.Meta;
|
||||
when Kind_Builtin =>
|
||||
return Mal.Nil;
|
||||
when others =>
|
||||
@ -203,14 +194,14 @@ package body Core is
|
||||
end;
|
||||
end Meta;
|
||||
|
||||
procedure NS_Add_To_Repl is
|
||||
procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is
|
||||
procedure P (S : in Symbols.Ptr;
|
||||
B : in Mal.Builtin_Ptr) with Inline;
|
||||
procedure P (S : in Symbols.Ptr;
|
||||
B : in Mal.Builtin_Ptr)
|
||||
is
|
||||
begin
|
||||
Envs.Repl.Set (S, (Kind_Builtin, B));
|
||||
Repl.all.Set (S, (Kind_Builtin, B));
|
||||
end P;
|
||||
begin
|
||||
P (Symbols.Constructor ("+"), Addition'Access);
|
||||
@ -227,7 +218,6 @@ package body Core is
|
||||
P (Symbols.Constructor ("/"), Division'Access);
|
||||
P (Symbols.Constructor ("do"), Mal_Do'Access);
|
||||
P (Symbols.Constructor ("="), Equals'Access);
|
||||
P (Symbols.Constructor ("eval"), Eval'Access);
|
||||
P (Symbols.Constructor ("first"), Sequences.First'Access);
|
||||
P (Symbols.Constructor ("get"), Maps.Get'Access);
|
||||
P (Symbols.Constructor (">="), Greater_Equal'Access);
|
||||
@ -360,7 +350,7 @@ package body Core is
|
||||
end;
|
||||
end if;
|
||||
when Kind_Sequence =>
|
||||
if Args (Args'First).Sequence.Length = 0 then
|
||||
if Args (Args'First).Sequence.all.Length = 0 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
return (Kind_List, Args (Args'First).Sequence);
|
||||
@ -427,17 +417,17 @@ package body Core is
|
||||
begin
|
||||
case A1.Kind is
|
||||
when Kind_Builtin_With_Meta =>
|
||||
return A1.Builtin_With_Meta.With_Meta (A2);
|
||||
return Builtins.With_Meta (A1.Builtin_With_Meta.all, A2);
|
||||
when Kind_Builtin =>
|
||||
return Builtins.With_Meta (A1.Builtin, A2);
|
||||
when Kind_List =>
|
||||
return (Kind_List, A1.Sequence.With_Meta (A2));
|
||||
return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2));
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, A1.Sequence.With_Meta (A2));
|
||||
return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2));
|
||||
when Kind_Map =>
|
||||
return A1.Map.With_Meta (A2);
|
||||
return Maps.With_Meta (A1.Map.all, A2);
|
||||
when Kind_Fn =>
|
||||
return A1.Fn.With_Meta (A2);
|
||||
return Fns.With_Meta (A1.Fn.all, A2);
|
||||
when others =>
|
||||
Err.Raise_With
|
||||
("parameter 1 must be a function, map or sequence");
|
||||
|
@ -1,6 +1,8 @@
|
||||
with Envs;
|
||||
|
||||
package Core with Elaborate_Body is
|
||||
|
||||
procedure NS_Add_To_Repl;
|
||||
-- Add built-in functions to Envs.Repl.
|
||||
procedure NS_Add_To_Repl (Repl : in Envs.Ptr);
|
||||
-- Add built-in functions.
|
||||
|
||||
end Core;
|
||||
|
446
ada.2/envs.adb
446
ada.2/envs.adb
@ -1,6 +1,4 @@
|
||||
with Ada.Containers.Hashed_Maps;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Err;
|
||||
with Printer;
|
||||
@ -11,417 +9,93 @@ package body Envs is
|
||||
|
||||
use Types;
|
||||
|
||||
-- The Eval built-in uses the REPL root environment (index 1),
|
||||
-- all others parameters only repeat the top index.
|
||||
|
||||
package HM is new Ada.Containers.Hashed_Maps
|
||||
(Key_Type => Symbols.Ptr,
|
||||
Element_Type => Mal.T,
|
||||
Hash => Symbols.Hash,
|
||||
Equivalent_Keys => Symbols."=",
|
||||
"=" => Mal."=");
|
||||
|
||||
type Stack_Record
|
||||
(Outer_On_Stack : Boolean := True) is record
|
||||
Data : HM.Map := HM.Empty_Map;
|
||||
Refs : Natural := 1;
|
||||
-- Only references via the Ptr type.
|
||||
-- References from the stack or Alias are not counted here.
|
||||
Alias : Heap_Access := null;
|
||||
-- Used by the closures and heap records to refer to this stack
|
||||
-- record, so that if it moves to the heap we only need to
|
||||
-- update the alias.
|
||||
case Outer_On_Stack is
|
||||
when True =>
|
||||
Outer_Index : Stack_Index := 0;
|
||||
when False =>
|
||||
Outer_Ref : Heap_Access := null;
|
||||
end case;
|
||||
end record
|
||||
with Dynamic_Predicate => 0 < Refs
|
||||
and (Alias = null or else Alias.all.Outer = null)
|
||||
and (if Outer_On_Stack
|
||||
then Outer_Index <= Top
|
||||
else Outer_Ref /= null);
|
||||
|
||||
-- It is forbidden to change the discriminant of an access type,
|
||||
-- so we cannot use a discriminant here.
|
||||
type Heap_Record is limited record
|
||||
Refs : Natural := 1;
|
||||
Data : HM.Map := HM.Empty_Map;
|
||||
Index : Stack_Index;
|
||||
Outer : Heap_Access := null;
|
||||
end record
|
||||
with Dynamic_Predicate =>
|
||||
(if Outer = null
|
||||
then Index in 1 .. Top and Data.Is_Empty
|
||||
else 0 < Refs);
|
||||
-- Either an alias for a stack element or an actual environment.
|
||||
|
||||
-- There could be one single type, but this would enlarge the
|
||||
-- stack without simplifying the code, and prevent some more
|
||||
-- static type checking.
|
||||
|
||||
Stack : array (Stack_Index range 1 .. Stack_Index'Last) of Stack_Record;
|
||||
-- The default value gives a consistent value to Stack (1),
|
||||
-- compatible with the Repl constant.
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access);
|
||||
Allocations : Natural := 0;
|
||||
|
||||
procedure Unreference (Reference : in out Heap_Access);
|
||||
|
||||
procedure Set_Binds (M : in out HM.Map;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array);
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
procedure Adjust (Object : in out Closure_Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null then
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end if;
|
||||
end Adjust;
|
||||
|
||||
procedure Clear_And_Check_Allocations is
|
||||
begin
|
||||
pragma Assert (Top = 1);
|
||||
pragma Assert (Stack (1).Refs = 1);
|
||||
Stack (1).Data.Clear;
|
||||
if Stack (1).Alias /= null then
|
||||
if Stack (1).Alias.all.Refs /= 0 then
|
||||
Dump_Stack (Long => True);
|
||||
end if;
|
||||
pragma Assert (Stack (1).Alias.all.Refs = 0);
|
||||
Allocations := Allocations - 1;
|
||||
Free (Stack (1).Alias);
|
||||
end if;
|
||||
pragma Assert (Allocations = 0);
|
||||
end Clear_And_Check_Allocations;
|
||||
|
||||
function Copy_Pointer (Env : in Ptr) return Ptr is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
begin
|
||||
Stack (Env.Index).Refs := @ + 1;
|
||||
return (Ada.Finalization.Limited_Controlled with Env.Index);
|
||||
end Copy_Pointer;
|
||||
|
||||
procedure Dump_Stack (Long : in Boolean) is
|
||||
procedure Dump_Stack (Env : in Instance) is
|
||||
use Ada.Text_IO;
|
||||
begin
|
||||
for I in 1 .. Top loop
|
||||
if Long then
|
||||
Put ("Level");
|
||||
end if;
|
||||
Put (I'Img);
|
||||
if Long then
|
||||
New_Line;
|
||||
Put_Line (" refs=" & Stack (I).Refs'Img);
|
||||
if Stack (I).Alias = null then
|
||||
Put_Line (" no alias");
|
||||
else
|
||||
Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img
|
||||
& " refs");
|
||||
end if;
|
||||
end if;
|
||||
if Long then
|
||||
Put (" outer=");
|
||||
else
|
||||
Put (" (->");
|
||||
end if;
|
||||
if Stack (I).Outer_On_Stack then
|
||||
Put (Stack (I).Outer_Index'Img);
|
||||
elsif Stack (I).Outer_Ref.all.Outer = null then
|
||||
if Long then
|
||||
Put ("alias for ");
|
||||
end if;
|
||||
Put (Stack (I).Outer_Ref.all.Index'Img);
|
||||
else
|
||||
Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img);
|
||||
end if;
|
||||
if Long then
|
||||
New_Line;
|
||||
else
|
||||
Put ("):");
|
||||
end if;
|
||||
for P in Stack (I).Data.Iterate loop
|
||||
if HM.Element (P).Kind /= Kind_Builtin or 1 < I then
|
||||
Put_Line ("environment:");
|
||||
for P in Env.Data.Iterate loop
|
||||
-- Do not print builtins for repl.
|
||||
if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then
|
||||
Put (" ");
|
||||
Put (HM.Key (P).To_String);
|
||||
Put (':');
|
||||
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
|
||||
if Long then
|
||||
New_Line;
|
||||
end if;
|
||||
end loop;
|
||||
if Env.Outer /= null then
|
||||
Put ("outer is ");
|
||||
Env.Outer.all.Dump_Stack;
|
||||
end if;
|
||||
end loop;
|
||||
New_Line;
|
||||
end loop;
|
||||
end Dump_Stack;
|
||||
|
||||
procedure Finalize (Object : in out Closure_Ptr) is
|
||||
begin
|
||||
Unreference (Object.Ref);
|
||||
end Finalize;
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if 0 < Object.Index then
|
||||
if 0 < Stack (Object.Index).Refs then
|
||||
Stack (Object.Index).Refs := @ - 1;
|
||||
end if;
|
||||
Object.Index := 0;
|
||||
|
||||
-- If Index = Top and there are no more references.
|
||||
loop
|
||||
pragma Assert (0 < Top);
|
||||
declare
|
||||
R : Stack_Record renames Stack (Top);
|
||||
begin
|
||||
exit when 0 < R.Refs;
|
||||
|
||||
if Top = 1 then
|
||||
R.Data.Clear;
|
||||
if R.Alias /= null then
|
||||
pragma Assert (R.Alias.all.Outer = null);
|
||||
pragma Assert (R.Alias.all.Refs = 0);
|
||||
Allocations := Allocations - 1;
|
||||
Free (R.Alias);
|
||||
end if;
|
||||
exit;
|
||||
elsif R.Alias = null then
|
||||
R.Data.Clear;
|
||||
if not R.Outer_On_Stack then
|
||||
Unreference (R.Outer_Ref);
|
||||
end if;
|
||||
elsif R.Alias.all.Refs = 0 then
|
||||
pragma Assert (R.Alias.all.Outer = null);
|
||||
Allocations := Allocations - 1;
|
||||
Free (R.Alias);
|
||||
R.Data.Clear;
|
||||
if not R.Outer_On_Stack then
|
||||
Unreference (R.Outer_Ref);
|
||||
end if;
|
||||
else
|
||||
-- Detach this environment from the stack.
|
||||
|
||||
-- The reference count is already correct.
|
||||
|
||||
-- Copy the hashmap contents without reallocation..
|
||||
R.Alias.all.Data.Move (R.Data);
|
||||
|
||||
-- The Index will not be used anymore.
|
||||
|
||||
-- We need the parent to have an alias, in case it
|
||||
-- must be detached later.
|
||||
if R.Outer_On_Stack then
|
||||
declare
|
||||
O : Stack_Record renames Stack (R.Outer_Index);
|
||||
begin
|
||||
if O.Alias = null then
|
||||
Allocations := Allocations + 1;
|
||||
O.Alias := new Heap_Record'(Index => R.Outer_Index,
|
||||
others => <>);
|
||||
else
|
||||
O.Alias.all.Refs := @ + 1;
|
||||
end if;
|
||||
R.Alias.all.Outer := O.Alias;
|
||||
end;
|
||||
else
|
||||
R.Alias.all.Outer := R.Outer_Ref;
|
||||
end if;
|
||||
R.Alias := null;
|
||||
end if;
|
||||
end;
|
||||
Top := Top - 1;
|
||||
end loop;
|
||||
end if;
|
||||
end Finalize;
|
||||
|
||||
function Get (Evt : in Ptr;
|
||||
function Get (Env : in Instance;
|
||||
Key : in Symbols.Ptr) return Mal.T
|
||||
is
|
||||
pragma Assert (Evt.Index in 1 | Top);
|
||||
Index : Stack_Index := Evt.Index;
|
||||
Ref : Heap_Access;
|
||||
Definition : HM.Cursor;
|
||||
-- Trust the compiler to detect the tail call. A loop would
|
||||
-- require a Ptr parameter or a separated first iteration.
|
||||
Position : constant HM.Cursor := Env.Data.Find (Key);
|
||||
begin
|
||||
Main_Loop : loop
|
||||
Index_Loop : loop
|
||||
Definition := Stack (Index).Data.Find (Key);
|
||||
if HM.Has_Element (Definition) then
|
||||
return HM.Element (Definition);
|
||||
if HM.Has_Element (Position) then
|
||||
return HM.Element (Position);
|
||||
end if;
|
||||
exit Index_Loop when not Stack (Index).Outer_On_Stack;
|
||||
Index := Stack (Index).Outer_Index;
|
||||
exit Main_Loop when Index = 0;
|
||||
end loop Index_Loop;
|
||||
Ref := Stack (Index).Outer_Ref;
|
||||
Ref_Loop : loop
|
||||
Definition := Ref.all.Data.Find (Key);
|
||||
if HM.Has_Element (Definition) then
|
||||
return HM.Element (Definition);
|
||||
end if;
|
||||
exit Ref_Loop when Ref.all.Outer = null;
|
||||
Ref := Ref.all.Outer;
|
||||
end loop Ref_Loop;
|
||||
Index := Ref.all.Index;
|
||||
end loop Main_Loop;
|
||||
Err.Raise_With ("'" & Key.To_String & "' not found");
|
||||
Err.Check (Env.Outer /= null,
|
||||
"'" & Symbols.To_String (Key) & "' not found");
|
||||
return Env.Outer.all.Get (Key);
|
||||
end Get;
|
||||
|
||||
function New_Closure (Env : in Ptr'Class) return Closure_Ptr is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
Alias : Heap_Access renames Stack (Env.Index).Alias;
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
-- Same remarks than for Get.
|
||||
begin
|
||||
if Alias = null then
|
||||
Allocations := Allocations + 1;
|
||||
Alias := new Heap_Record'(Index => Env.Index, others => <>);
|
||||
else
|
||||
Alias.all.Refs := @ + 1;
|
||||
for Element of Object.Data loop
|
||||
Mal.Keep (Element);
|
||||
end loop;
|
||||
if Object.Outer /= null then
|
||||
Object.Outer.all.Keep;
|
||||
end if;
|
||||
return (Ada.Finalization.Controlled with Alias);
|
||||
end New_Closure;
|
||||
end Keep_References;
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr) is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
R : Stack_Record renames Stack (Env.Index);
|
||||
begin
|
||||
if Env.Index < Top or 1 < R.Refs
|
||||
or (R.Alias /= null and then 0 < R.Alias.all.Refs)
|
||||
then
|
||||
R.Refs := @ - 1;
|
||||
Top := Top + 1;
|
||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
||||
pragma Assert (Stack (Top).Alias = null);
|
||||
Stack (Top) := (Outer_Index => Env.Index,
|
||||
others => <>);
|
||||
Env.Index := Top;
|
||||
end if;
|
||||
-- Else reuse the top stack record, including its map and its
|
||||
-- unreferenced alias if any.
|
||||
end Replace_With_Sub;
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr;
|
||||
Outer : in Closure_Ptr'Class;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array)
|
||||
is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
begin
|
||||
-- Finalize Env before creating the new environment, in case
|
||||
-- this is the last reference and it can be forgotten.
|
||||
-- Automatic assignment would construct the new value before
|
||||
-- finalizing the old one.
|
||||
Finalize (Env);
|
||||
Outer.Ref.all.Refs := @ + 1;
|
||||
Top := Top + 1;
|
||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
||||
pragma Assert (Stack (Top).Alias = null);
|
||||
Stack (Top) := (Outer_On_Stack => False,
|
||||
Outer_Ref => Outer.Ref,
|
||||
others => <>);
|
||||
Env.Index := Top;
|
||||
-- Now we can afford raising exceptions.
|
||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
||||
end Replace_With_Sub;
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array)
|
||||
is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
begin
|
||||
Replace_With_Sub (Env);
|
||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
||||
end Replace_With_Sub;
|
||||
|
||||
procedure Set (Env : in Ptr;
|
||||
Key : in Symbols.Ptr;
|
||||
New_Element : in Mal.T)
|
||||
is
|
||||
pragma Assert (Env.Index in 1 | Top);
|
||||
begin
|
||||
Stack (Env.Index).Data.Include (Key, New_Element);
|
||||
end Set;
|
||||
|
||||
procedure Set_Binds (M : in out HM.Map;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array)
|
||||
function New_Env (Outer : in Ptr := null;
|
||||
Binds : in Symbols.Symbol_Array := No_Binds;
|
||||
Exprs : in Mal.T_Array := No_Exprs) return Ptr
|
||||
is
|
||||
use type Symbols.Ptr;
|
||||
Varargs : constant Boolean := 1 < Binds'Length and then
|
||||
Binds (Binds'Last - 1) = Symbols.Names.Ampersand;
|
||||
Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with
|
||||
Outer => Outer,
|
||||
Data => HM.Empty_Map);
|
||||
begin
|
||||
Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length
|
||||
else Exprs'Length = Binds'Length),
|
||||
"actual parameters do not match formal parameters");
|
||||
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop
|
||||
M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I));
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
if 2 <= Binds'Length
|
||||
and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand
|
||||
then
|
||||
Err.Check (Binds'Length - 2 <= Exprs'Length,
|
||||
"not enough actual parameters for vararg function");
|
||||
for I in 0 .. Binds'Length - 3 loop
|
||||
Ref.all.Data.Include (Key => Binds (Binds'First + I),
|
||||
New_Item => Exprs (Exprs'First + I));
|
||||
end loop;
|
||||
if Varargs then
|
||||
M.Include (Binds (Binds'Last), Sequences.List
|
||||
Ref.all.Data.Include (Key => Binds (Binds'Last),
|
||||
New_Item => Sequences.List
|
||||
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
|
||||
end if;
|
||||
end Set_Binds;
|
||||
|
||||
function Sub (Outer : in Ptr;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array) return Ptr
|
||||
is
|
||||
pragma Assert (Outer.Index in 1 | Top);
|
||||
begin
|
||||
Top := Top + 1;
|
||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
||||
pragma Assert (Stack (Top).Alias = null);
|
||||
Stack (Top) := (Outer_Index => Outer.Index,
|
||||
others => <>);
|
||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
||||
return (Ada.Finalization.Limited_Controlled with Top);
|
||||
end Sub;
|
||||
|
||||
function Sub (Outer : in Closure_Ptr'Class;
|
||||
Binds : in Symbols.Symbol_Array;
|
||||
Exprs : in Mal.T_Array) return Ptr
|
||||
is
|
||||
begin
|
||||
Outer.Ref.all.Refs := @ + 1;
|
||||
Top := Top + 1;
|
||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
||||
pragma Assert (Stack (Top).Alias = null);
|
||||
Stack (Top) := (Outer_On_Stack => False,
|
||||
Outer_Ref => Outer.Ref,
|
||||
others => <>);
|
||||
-- Take care to construct the result before raising any
|
||||
-- exception, so that it is finalized correctly.
|
||||
return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top)
|
||||
do
|
||||
-- Now we can afford raising exceptions.
|
||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
||||
end return;
|
||||
end Sub;
|
||||
|
||||
procedure Unreference (Reference : in out Heap_Access) is
|
||||
Ref : Heap_Access := Reference;
|
||||
begin
|
||||
Reference := null;
|
||||
loop
|
||||
exit when Ref = null;
|
||||
exit when Ref.all.Refs = 0;
|
||||
Ref.all.Refs := @ - 1;
|
||||
exit when 0 < Ref.all.Refs;
|
||||
exit when Ref.all.Outer = null; -- An alias. Do not free it
|
||||
-- now, it may be useful for another closure.
|
||||
declare
|
||||
Tmp : Heap_Access := Ref;
|
||||
begin
|
||||
Ref := Ref.all.Outer;
|
||||
Allocations := Allocations - 1;
|
||||
Free (Tmp);
|
||||
pragma Unreferenced (Tmp);
|
||||
end;
|
||||
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 Unreference;
|
||||
end if;
|
||||
return Ref;
|
||||
end New_Env;
|
||||
|
||||
procedure Set (Env : in out Instance;
|
||||
Key : in Symbols.Ptr;
|
||||
New_Item : in Mal.T)
|
||||
is
|
||||
begin
|
||||
Env.Data.Include (Key, New_Item);
|
||||
end Set;
|
||||
|
||||
end Envs;
|
||||
|
143
ada.2/envs.ads
143
ada.2/envs.ads
@ -1,138 +1,49 @@
|
||||
private with Ada.Finalization;
|
||||
private with Ada.Containers.Hashed_Maps;
|
||||
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
with Types.Symbols;
|
||||
|
||||
package Envs with Elaborate_Body is
|
||||
package Envs is
|
||||
|
||||
-- This package should be named Env, but Ada does not allow formal
|
||||
-- parameters to be named like a package dependency, and it seems
|
||||
-- that readability inside Eval is more important.
|
||||
|
||||
-- This implementation relies on the fact that the caller only
|
||||
-- ever references environments in its execution stack.
|
||||
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||
type Ptr is access Instance;
|
||||
|
||||
-- When a function closure references an environment that the
|
||||
-- execution leaves behind, a dynamically allocated block is used
|
||||
-- instead.
|
||||
No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array;
|
||||
No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil);
|
||||
|
||||
-- The eval built-in requires REPL (see the implementation of
|
||||
-- load-file), so we cannot assume that the caller only sees the
|
||||
-- current environment.
|
||||
function New_Env (Outer : in Ptr := null;
|
||||
Binds : in Types.Symbols.Symbol_Array := No_Binds;
|
||||
Exprs : in Types.Mal.T_Array := No_Exprs)
|
||||
return Ptr;
|
||||
|
||||
type Ptr (<>) is tagged limited private;
|
||||
-- This type is controlled in order count the references to a
|
||||
-- given environment, even during exception propagation.
|
||||
-- Since Ptr is limited with a hidden discriminant, any variable
|
||||
-- must immediately be assigned with one of
|
||||
-- * Copy_Pointer,
|
||||
-- * Sub (either from a Ptr or from a Closure_Ptr).
|
||||
-- Usual assignment with reference counting is not provided
|
||||
-- because we want to enforce the use of the more efficient
|
||||
-- Replace_With_Sub.
|
||||
|
||||
Repl : constant Ptr;
|
||||
-- The top environment.
|
||||
|
||||
function Copy_Pointer (Env : in Ptr) return Ptr with Inline;
|
||||
-- Allows assignment to a freshly created variable. This is
|
||||
-- required for tail call optimization, but should be avoided
|
||||
-- elsewhere.
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr) with Inline;
|
||||
-- for let*
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr;
|
||||
Binds : in Types.Symbols.Symbol_Array;
|
||||
Exprs : in Types.Mal.T_Array) with Inline;
|
||||
-- when expanding macros.
|
||||
|
||||
procedure Set (Env : in Ptr;
|
||||
Key : in Types.Symbols.Ptr;
|
||||
New_Element : in Types.Mal.T)
|
||||
with Inline;
|
||||
|
||||
-- The Find method is merged into the Get method.
|
||||
|
||||
function Get (Evt : in Ptr;
|
||||
function Get (Env : in Instance;
|
||||
Key : in Types.Symbols.Ptr) return Types.Mal.T;
|
||||
-- Raises Core.Error_Exception if the key is not found.
|
||||
|
||||
-- Function closures.
|
||||
procedure Set (Env : in out Instance;
|
||||
Key : in Types.Symbols.Ptr;
|
||||
New_Item : in Types.Mal.T) with Inline;
|
||||
|
||||
type Closure_Ptr is tagged private;
|
||||
Null_Closure : constant Closure_Ptr;
|
||||
|
||||
function New_Closure (Env : in Ptr'Class) return Closure_Ptr;
|
||||
-- The class-wide argument does not make much sense, but avoids
|
||||
-- the compiler wondering on which type is should dispatch.
|
||||
|
||||
function Sub (Outer : in Closure_Ptr'Class;
|
||||
Binds : in Types.Symbols.Symbol_Array;
|
||||
Exprs : in Types.Mal.T_Array) return Ptr;
|
||||
-- when applying functions without tail call optimization.
|
||||
-- Construct a new environment with the given outer parent.
|
||||
-- Then call Set with the paired elements of Binds and Exprs,
|
||||
-- handling the "&" special formal parameter if present.
|
||||
-- May raise Error.
|
||||
|
||||
procedure Replace_With_Sub (Env : in out Ptr;
|
||||
Outer : in Closure_Ptr'Class;
|
||||
Binds : in Types.Symbols.Symbol_Array;
|
||||
Exprs : in Types.Mal.T_Array);
|
||||
-- when applying functions with tail call optimization.
|
||||
-- Equivalent to Env := Sub (Env, Binds, Exprs), except that such
|
||||
-- an assignment is forbidden or discouraged for performance reasons.
|
||||
|
||||
function Sub (Outer : in Ptr;
|
||||
Binds : in Types.Symbols.Symbol_Array;
|
||||
Exprs : in Types.Mal.T_Array) return Ptr;
|
||||
-- when applying macros
|
||||
|
||||
-- Debugging.
|
||||
procedure Dump_Stack (Long : in Boolean);
|
||||
procedure Clear_And_Check_Allocations;
|
||||
-- Debug.
|
||||
procedure Dump_Stack (Env : in Instance);
|
||||
|
||||
private
|
||||
|
||||
-- There must be a reference level so that functions may keep
|
||||
-- track of their initial environment, and another one for
|
||||
-- reallocations. The second one is delegated to a predefined Ada
|
||||
-- container.
|
||||
package HM is new Ada.Containers.Hashed_Maps
|
||||
(Key_Type => Types.Symbols.Ptr,
|
||||
Element_Type => Types.Mal.T,
|
||||
Hash => Types.Symbols.Hash,
|
||||
Equivalent_Keys => Types.Symbols."=",
|
||||
"=" => Types.Mal."=");
|
||||
|
||||
-- MAL maps may be tempting, but we do not want to copy the whole
|
||||
-- map for each addition or removal.
|
||||
|
||||
-- Some tests seem to show that a hashmap is three times faster
|
||||
-- than a vector with (key, value) couples.
|
||||
|
||||
-- We allow the null value so that the empty environment in a
|
||||
-- macro does not trigger an allocation.
|
||||
|
||||
type Stack_Index is range 0 .. 200;
|
||||
|
||||
-- See README for the implementation of reference counting.
|
||||
|
||||
type Ptr is new Ada.Finalization.Limited_Controlled with record
|
||||
Index : Stack_Index := 0;
|
||||
end record
|
||||
with Invariant => Ptr.Index in 1 .. Top;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
|
||||
Top : Stack_Index := 1;
|
||||
Repl : constant Ptr := (Ada.Finalization.Limited_Controlled with 1);
|
||||
|
||||
type Heap_Record;
|
||||
type Heap_Access is access Heap_Record;
|
||||
type Closure_Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Heap_Access := null;
|
||||
type Instance is new Garbage_Collected.Instance with record
|
||||
Outer : Ptr;
|
||||
Data : HM.Map;
|
||||
end record;
|
||||
overriding procedure Adjust (Object : in out Closure_Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Closure_Ptr) with Inline;
|
||||
pragma Finalize_Storage_Only (Closure_Ptr);
|
||||
|
||||
Null_Closure : constant Closure_Ptr
|
||||
:= (Ada.Finalization.Controlled with null);
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Envs;
|
||||
|
54
ada.2/garbage_collected.adb
Normal file
54
ada.2/garbage_collected.adb
Normal 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
45
ada.2/garbage_collected.ads
Normal 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;
|
@ -22,10 +22,10 @@ package body Printer is
|
||||
|
||||
-- Helpers for Print_Form.
|
||||
procedure Print_Number (Number : in Integer) with Inline;
|
||||
procedure Print_List (List : in Sequences.Ptr) with Inline;
|
||||
procedure Print_Map (Map : in Maps.Ptr) with Inline;
|
||||
procedure Print_List (List : in Sequences.Instance) with Inline;
|
||||
procedure Print_Map (Map : in Maps.Instance) with Inline;
|
||||
procedure Print_Readably (S : in Unbounded_String) with Inline;
|
||||
procedure Print_Function (Fn : in Fns.Ptr) with Inline;
|
||||
procedure Print_Function (Fn : in Fns.Instance) with Inline;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
@ -41,7 +41,7 @@ package body Printer is
|
||||
Append (Buffer, "false");
|
||||
end if;
|
||||
when Kind_Symbol =>
|
||||
Append (Buffer, Form_Ast.Symbol.To_String);
|
||||
Append (Buffer, Symbols.To_String (Form_Ast.Symbol));
|
||||
when Kind_Number =>
|
||||
Print_Number (Form_Ast.Number);
|
||||
when Kind_Keyword =>
|
||||
@ -57,34 +57,34 @@ package body Printer is
|
||||
end if;
|
||||
when Kind_List =>
|
||||
Append (Buffer, '(');
|
||||
Print_List (Form_Ast.Sequence);
|
||||
Print_List (Form_Ast.Sequence.all);
|
||||
Append (Buffer, ')');
|
||||
when Kind_Vector =>
|
||||
Append (Buffer, '[');
|
||||
Print_List (Form_Ast.Sequence);
|
||||
Print_List (Form_Ast.Sequence.all);
|
||||
Append (Buffer, ']');
|
||||
when Kind_Map =>
|
||||
Append (Buffer, '{');
|
||||
Print_Map (Form_Ast.Map);
|
||||
Print_Map (Form_Ast.Map.all);
|
||||
Append (Buffer, '}');
|
||||
when Kind_Builtin | Kind_Builtin_With_Meta =>
|
||||
Append (Buffer, "#<built-in>");
|
||||
when Kind_Fn =>
|
||||
Append (Buffer, "#<function (");
|
||||
Print_Function (Form_Ast.Fn);
|
||||
Print_Function (Form_Ast.Fn.all);
|
||||
Append (Buffer, '>');
|
||||
when Kind_Macro =>
|
||||
Append (Buffer, "#<macro (");
|
||||
Print_Function (Form_Ast.Fn);
|
||||
Print_Function (Form_Ast.Fn.all);
|
||||
Append (Buffer, '>');
|
||||
when Kind_Atom =>
|
||||
Append (Buffer, "(atom ");
|
||||
Print_Form (Atoms.Deref (Form_Ast.Atom));
|
||||
Print_Form (Form_Ast.Atom.all.Deref);
|
||||
Append (Buffer, ')');
|
||||
end case;
|
||||
end Print_Form;
|
||||
|
||||
procedure Print_Function (Fn : in Fns.Ptr) is
|
||||
procedure Print_Function (Fn : in Fns.Instance) is
|
||||
Started : Boolean := False;
|
||||
begin
|
||||
Append (Buffer, '(');
|
||||
@ -94,13 +94,13 @@ package body Printer is
|
||||
else
|
||||
Started := True;
|
||||
end if;
|
||||
Append (Buffer, Param.To_String);
|
||||
Append (Buffer, Symbols.To_String (Param));
|
||||
end loop;
|
||||
Append (Buffer, ") -> ");
|
||||
Print_Form (Fn.Ast);
|
||||
end Print_Function;
|
||||
|
||||
procedure Print_List (List : in Sequences.Ptr) is
|
||||
procedure Print_List (List : in Sequences.Instance) is
|
||||
begin
|
||||
if 0 < List.Length then
|
||||
Print_Form (List (1));
|
||||
@ -111,7 +111,7 @@ package body Printer is
|
||||
end if;
|
||||
end Print_List;
|
||||
|
||||
procedure Print_Map (Map : in Maps.Ptr) is
|
||||
procedure Print_Map (Map : in Maps.Instance) is
|
||||
procedure Process (Key : in Mal.T;
|
||||
Element : in Mal.T) with Inline;
|
||||
procedure Iterate is new Maps.Iterate (Process);
|
||||
|
123
ada.2/reader.adb
123
ada.2/reader.adb
@ -13,7 +13,7 @@ with Types.Symbols.Names;
|
||||
|
||||
package body Reader is
|
||||
|
||||
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader");
|
||||
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread");
|
||||
|
||||
use Types;
|
||||
use type Ada.Strings.Maps.Character_Set;
|
||||
@ -37,7 +37,7 @@ package body Reader is
|
||||
B_Last : Natural := Buffer'First - 1;
|
||||
-- Index in Buffer of the currently written MAL expression.
|
||||
|
||||
procedure Read_Form;
|
||||
function Read_Form return Mal.T;
|
||||
-- The recursive part of Read_Str.
|
||||
|
||||
-- Helpers for Read_Form:
|
||||
@ -58,124 +58,127 @@ package body Reader is
|
||||
|
||||
-- Read_Atom has been merged into the same case/switch
|
||||
-- statement, for clarity and efficiency.
|
||||
procedure Read_List (Ending : in Character;
|
||||
Constructor : in not null Mal.Builtin_Ptr)
|
||||
with Inline;
|
||||
procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline;
|
||||
procedure Read_String with Inline;
|
||||
procedure Read_With_Meta with Inline;
|
||||
|
||||
function Read_List (Ending : in Character) return Natural with Inline;
|
||||
-- Returns the index of the last elements in Buffer.
|
||||
-- The elements have been stored in Buffer (B_Last .. result).
|
||||
|
||||
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline;
|
||||
|
||||
function Read_String return Mal.T with Inline;
|
||||
|
||||
function Read_With_Meta return Mal.T with Inline;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
procedure Read_List (Ending : in Character;
|
||||
Constructor : in not null Mal.Builtin_Ptr) is
|
||||
function Read_List (Ending : in Character) return Natural is
|
||||
Opening : constant Character := Source (I);
|
||||
B_First : constant Positive := B_Last;
|
||||
Old : constant Natural := B_Last;
|
||||
Result : Positive;
|
||||
begin
|
||||
I := I + 1; -- Skip (, [ or {.
|
||||
loop
|
||||
Skip_Ignored;
|
||||
Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'");
|
||||
exit when Source (I) = Ending;
|
||||
Read_Form;
|
||||
B_Last := B_Last + 1;
|
||||
Buffer (B_Last) := Read_Form;
|
||||
end loop;
|
||||
I := I + 1; -- Skip ), ] or }.
|
||||
Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1));
|
||||
B_Last := B_First;
|
||||
Result := B_Last;
|
||||
B_Last := Old;
|
||||
return Result;
|
||||
end Read_List;
|
||||
|
||||
procedure Read_Quote (Symbol : in Symbols.Ptr) is
|
||||
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is
|
||||
R : constant Mal.Sequence_Ptr := Sequences.Constructor (2);
|
||||
begin
|
||||
Buffer (B_Last) := (Kind_Symbol, Symbol);
|
||||
I := I + 1; -- Skip the initial ' or similar.
|
||||
R.Replace_Element (1, (Kind_Symbol, Symbol));
|
||||
Skip_Ignored;
|
||||
Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'");
|
||||
B_Last := B_Last + 1;
|
||||
Read_Form;
|
||||
B_Last := B_Last - 1;
|
||||
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1));
|
||||
Err.Check (I <= Source'Last,
|
||||
"Incomplete '" & Symbols.To_String (Symbol) & "'");
|
||||
R.Replace_Element (2, Read_Form);
|
||||
return (Kind_List, R);
|
||||
end Read_Quote;
|
||||
|
||||
procedure Read_Form is
|
||||
function Read_Form return Mal.T is
|
||||
-- After I has been increased, current token is be
|
||||
-- Source (F .. I - 1).
|
||||
F : Positive;
|
||||
R : Mal.T; -- The result of this function.
|
||||
begin
|
||||
case Source (I) is
|
||||
when ')' | ']' | '}' =>
|
||||
Err.Raise_With ("unbalanced '" & Source (I) & "'");
|
||||
when '"' =>
|
||||
Read_String;
|
||||
R := Read_String;
|
||||
when ':' =>
|
||||
I := I + 1;
|
||||
F := I;
|
||||
Skip_Symbol;
|
||||
Buffer (B_Last) := (Kind_Keyword,
|
||||
Ada.Strings.Unbounded.To_Unbounded_String
|
||||
R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String
|
||||
(Source (F .. I - 1)));
|
||||
when '-' =>
|
||||
F := I;
|
||||
Skip_Digits;
|
||||
if F + 1 < I then
|
||||
Buffer (B_Last) := (Kind_Number,
|
||||
Integer'Value (Source (F .. I - 1)));
|
||||
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
|
||||
else
|
||||
Skip_Symbol;
|
||||
Buffer (B_Last) := (Kind_Symbol,
|
||||
R := (Kind_Symbol,
|
||||
Symbols.Constructor (Source (F .. I - 1)));
|
||||
end if;
|
||||
when '~' =>
|
||||
if I < Source'Last and then Source (I + 1) = '@' then
|
||||
I := I + 1;
|
||||
Read_Quote (Symbols.Names.Splice_Unquote);
|
||||
R := Read_Quote (Symbols.Names.Splice_Unquote);
|
||||
else
|
||||
Read_Quote (Symbols.Names.Unquote);
|
||||
R := Read_Quote (Symbols.Names.Unquote);
|
||||
end if;
|
||||
when '0' .. '9' =>
|
||||
F := I;
|
||||
Skip_Digits;
|
||||
Buffer (B_Last) := (Kind_Number,
|
||||
Integer'Value (Source (F .. I - 1)));
|
||||
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
|
||||
when ''' =>
|
||||
Read_Quote (Symbols.Names.Quote);
|
||||
R := Read_Quote (Symbols.Names.Quote);
|
||||
when '`' =>
|
||||
Read_Quote (Symbols.Names.Quasiquote);
|
||||
R := Read_Quote (Symbols.Names.Quasiquote);
|
||||
when '@' =>
|
||||
Read_Quote (Symbols.Names.Deref);
|
||||
R := Read_Quote (Symbols.Names.Deref);
|
||||
when '^' =>
|
||||
Read_With_Meta;
|
||||
R := Read_With_Meta;
|
||||
when '(' =>
|
||||
Read_List (')', Sequences.List'Access);
|
||||
R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')')));
|
||||
when '[' =>
|
||||
Read_List (']', Sequences.Vector'Access);
|
||||
R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']')));
|
||||
when '{' =>
|
||||
Read_List ('}', Maps.Hash_Map'Access);
|
||||
R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}')));
|
||||
when others =>
|
||||
F := I;
|
||||
Skip_Symbol;
|
||||
if Source (F .. I - 1) = "false" then
|
||||
Buffer (B_Last) := (Kind_Boolean, False);
|
||||
R := (Kind_Boolean, False);
|
||||
elsif Source (F .. I - 1) = "nil" then
|
||||
Buffer (B_Last) := Mal.Nil;
|
||||
R := Mal.Nil;
|
||||
elsif Source (F .. I - 1) = "true" then
|
||||
Buffer (B_Last) := (Kind_Boolean, True);
|
||||
R := (Kind_Boolean, True);
|
||||
else
|
||||
Buffer (B_Last) := (Kind_Symbol,
|
||||
R := (Kind_Symbol,
|
||||
Symbols.Constructor (Source (F .. I - 1)));
|
||||
end if;
|
||||
end case;
|
||||
if Debug then
|
||||
Ada.Text_IO.Put ("reader: ");
|
||||
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer
|
||||
(B_Last)));
|
||||
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R));
|
||||
end if;
|
||||
return R;
|
||||
end Read_Form;
|
||||
|
||||
procedure Read_String is
|
||||
function Read_String return Mal.T is
|
||||
use Ada.Strings.Unbounded;
|
||||
Result : Unbounded_String;
|
||||
begin
|
||||
Buffer (B_Last) := (Kind_String, Null_Unbounded_String);
|
||||
loop
|
||||
I := I + 1;
|
||||
Err.Check (I <= Source'Last, "unbalanced '""'");
|
||||
@ -187,33 +190,31 @@ package body Reader is
|
||||
Err.Check (I <= Source'Last, "unbalanced '""'");
|
||||
case Source (I) is
|
||||
when '\' | '"' =>
|
||||
Append (Buffer (B_Last).S, Source (I));
|
||||
Append (Result, Source (I));
|
||||
when 'n' =>
|
||||
Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF);
|
||||
Append (Result, Ada.Characters.Latin_1.LF);
|
||||
when others =>
|
||||
Append (Buffer (B_Last).S, Source (I - 1 .. I));
|
||||
Append (Result, Source (I - 1 .. I));
|
||||
end case;
|
||||
when others =>
|
||||
Append (Buffer (B_Last).S, Source (I));
|
||||
Append (Result, Source (I));
|
||||
end case;
|
||||
end loop;
|
||||
I := I + 1; -- Skip closing double quote.
|
||||
return (Kind_String, Result);
|
||||
end Read_String;
|
||||
|
||||
procedure Read_With_Meta is
|
||||
function Read_With_Meta return Mal.T is
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (3);
|
||||
begin
|
||||
I := I + 1; -- Skip the initial ^.
|
||||
for Argument in 1 .. 2 loop
|
||||
List.all.Replace_Element (1, (Kind_Symbol, Symbols.Names.With_Meta));
|
||||
for I in reverse 2 .. 3 loop
|
||||
Skip_Ignored;
|
||||
Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
|
||||
Read_Form;
|
||||
B_Last := B_Last + 1;
|
||||
List.all.Replace_Element (I, Read_Form);
|
||||
end loop;
|
||||
-- Replace (metadata data) with (with-meta data metadata).
|
||||
B_Last := B_Last - 2;
|
||||
Buffer (B_Last + 2) := Buffer (B_Last);
|
||||
Buffer (B_Last) := (Kind_Symbol, Symbols.Names.With_Meta);
|
||||
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 2));
|
||||
return (Kind_List, List);
|
||||
end Read_With_Meta;
|
||||
|
||||
procedure Skip_Digits is
|
||||
@ -259,7 +260,7 @@ package body Reader is
|
||||
Skip_Ignored;
|
||||
exit when Source'Last < I;
|
||||
B_Last := B_Last + 1;
|
||||
Read_Form;
|
||||
Buffer (B_Last) := Read_Form;
|
||||
end loop;
|
||||
return Buffer (Buffer'First .. B_Last);
|
||||
end Read_Str;
|
||||
|
@ -1,15 +1,11 @@
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
|
||||
with Err;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
with Types.Symbols;
|
||||
|
||||
procedure Step1_Read_Print is
|
||||
@ -56,14 +52,14 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step1_Read_Print;
|
||||
|
@ -4,12 +4,10 @@ with Ada.Strings.Hash;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
|
||||
with Err;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
@ -41,7 +39,6 @@ procedure Step2_Eval is
|
||||
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
||||
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Map, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@ -56,6 +53,7 @@ procedure Step2_Eval is
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -70,29 +68,40 @@ procedure Step2_Eval is
|
||||
return (Kind_Builtin, Envs.Element (C));
|
||||
end;
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Eval (Ast.Sequence (1), Env);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
First := Eval (First, Env);
|
||||
|
||||
-- Apply phase.
|
||||
-- Ast is a non-empty list,
|
||||
-- First is its non-special evaluated first element.
|
||||
-- First is its evaluated first element.
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
@ -147,14 +156,15 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step2_Eval;
|
||||
|
@ -3,12 +3,10 @@ with Ada.Text_IO.Unbounded_IO;
|
||||
|
||||
with Envs;
|
||||
with Err;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
@ -16,11 +14,7 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step3_Env is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
|
||||
@ -37,7 +31,6 @@ procedure Step3_Env is
|
||||
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
||||
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@ -52,60 +45,67 @@ procedure Step3_Env is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
-- This curious syntax is useful for later steps.
|
||||
New_Env : Envs.Ptr := Env.Copy_Pointer;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
New_Env : Envs.Ptr;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
New_Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
New_Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
New_Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), New_Env));
|
||||
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), New_Env));
|
||||
end loop;
|
||||
return Eval (Ast.Sequence (3), New_Env);
|
||||
return Eval (Ast.Sequence.all (3), New_Env);
|
||||
end;
|
||||
else
|
||||
First := Eval (First, Env);
|
||||
@ -120,10 +120,10 @@ procedure Step3_Env is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
@ -162,16 +162,18 @@ procedure Step3_Env is
|
||||
function Product is new Generic_Mal_Operator ("*");
|
||||
function Division is new Generic_Mal_Operator ("/");
|
||||
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
begin
|
||||
Repl.Set (Symbols.Constructor ("+"),
|
||||
-- Add Core functions into the top environment.
|
||||
Repl.all.Set (Symbols.Constructor ("+"),
|
||||
(Kind_Builtin, Addition 'Unrestricted_Access));
|
||||
Repl.Set (Symbols.Constructor ("-"),
|
||||
Repl.all.Set (Symbols.Constructor ("-"),
|
||||
(Kind_Builtin, Subtraction'Unrestricted_Access));
|
||||
Repl.Set (Symbols.Constructor ("*"),
|
||||
Repl.all.Set (Symbols.Constructor ("*"),
|
||||
(Kind_Builtin, Product 'Unrestricted_Access));
|
||||
Repl.Set (Symbols.Constructor ("/"),
|
||||
Repl.all.Set (Symbols.Constructor ("/"),
|
||||
(Kind_Builtin, Division 'Unrestricted_Access));
|
||||
-- Execute user commands.
|
||||
loop
|
||||
begin
|
||||
Rep (Repl);
|
||||
@ -182,15 +184,16 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step3_Env;
|
||||
|
@ -5,11 +5,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -18,11 +17,7 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step4_If_Fn_Do is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
@ -36,7 +31,6 @@ procedure Step4_If_Fn_Do is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -55,82 +49,90 @@ procedure Step4_If_Fn_Do is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
return Eval (Ast.Sequence (3), Env);
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
return Eval (Ast.Sequence.all (3), Env);
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
return Eval (Ast.Sequence (4), Env);
|
||||
return Eval (Ast.Sequence.all (4), Env);
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
-- This curious syntax is useful for later steps.
|
||||
New_Env : Envs.Ptr := Env.Copy_Pointer;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
New_Env : Envs.Ptr;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
New_Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
New_Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
New_Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), New_Env));
|
||||
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), New_Env));
|
||||
end loop;
|
||||
return Eval (Ast.Sequence (3), New_Env);
|
||||
return Eval (Ast.Sequence.all (3), New_Env);
|
||||
end;
|
||||
else
|
||||
First := Eval (First, Env);
|
||||
@ -145,21 +147,21 @@ procedure Step4_If_Fn_Do is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Fn.Apply (Args);
|
||||
return First.Fn.all.Apply (Args);
|
||||
end;
|
||||
when others =>
|
||||
Err.Raise_With ("first element must be a function");
|
||||
@ -200,14 +202,15 @@ procedure Step4_If_Fn_Do is
|
||||
|
||||
Startup : constant String
|
||||
:= "(def! not (fn* (a) (if a false true)))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Execute user commands.
|
||||
loop
|
||||
begin
|
||||
Rep (Repl);
|
||||
@ -218,15 +221,16 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step4_If_Fn_Do;
|
||||
|
@ -5,11 +5,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -18,11 +17,7 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step5_Tco is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
@ -36,7 +31,6 @@ procedure Step5_Tco is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -52,7 +46,7 @@ procedure Step5_Tco is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
First : Mal.T;
|
||||
begin
|
||||
<<Restart>>
|
||||
@ -60,88 +54,97 @@ procedure Step5_Tco is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -160,24 +163,24 @@ procedure Step5_Tco is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when others =>
|
||||
@ -219,14 +222,15 @@ procedure Step5_Tco is
|
||||
|
||||
Startup : constant String
|
||||
:= "(def! not (fn* (a) (if a false true)))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Execute user commands.
|
||||
loop
|
||||
begin
|
||||
Rep (Repl);
|
||||
@ -237,15 +241,16 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step5_Tco;
|
||||
|
@ -7,11 +7,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -20,26 +19,24 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step6_File is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
package ACL renames Ada.Command_Line;
|
||||
package ASU renames Ada.Strings.Unbounded;
|
||||
|
||||
function Read return Mal.T_Array with Inline;
|
||||
|
||||
function Eval (Ast0 : in Mal.T;
|
||||
Env0 : in Envs.Ptr) return Mal.T;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||
-- The built-in variant needs to see the Repl variable.
|
||||
|
||||
procedure Print (Ast : in Mal.T) with Inline;
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -55,7 +52,7 @@ procedure Step6_File is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
First : Mal.T;
|
||||
begin
|
||||
<<Restart>>
|
||||
@ -63,88 +60,97 @@ procedure Step6_File is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -163,24 +169,24 @@ procedure Step6_File is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when others =>
|
||||
@ -224,27 +230,37 @@ procedure Step6_File is
|
||||
:= "(def! not (fn* (a) (if a false true)))"
|
||||
& "(def! load-file (fn* (f)"
|
||||
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||
end Eval_Builtin;
|
||||
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||
Argv : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Define ARGV from command line arguments.
|
||||
declare
|
||||
use Ada.Command_Line;
|
||||
Args : Mal.T_Array (2 .. Argument_Count);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
||||
if Script then
|
||||
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||
for I in 2 .. ACL.Argument_Count loop
|
||||
Argv.all.Replace_Element
|
||||
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||
end loop;
|
||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
||||
end;
|
||||
-- Script?
|
||||
if 0 < Ada.Command_Line.Argument_Count then
|
||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
||||
else
|
||||
Argv := Sequences.Constructor (0);
|
||||
end if;
|
||||
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||
-- Execute user commands.
|
||||
if Script then
|
||||
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||
else
|
||||
loop
|
||||
begin
|
||||
@ -256,16 +272,17 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
end if;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step6_File;
|
||||
|
@ -1,4 +1,5 @@
|
||||
with Ada.Command_Line;
|
||||
with Ada.Containers.Vectors;
|
||||
with Ada.Environment_Variables;
|
||||
with Ada.Strings.Unbounded;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
@ -7,11 +8,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step7_Quote is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
package ACL renames Ada.Command_Line;
|
||||
package ASU renames Ada.Strings.Unbounded;
|
||||
|
||||
function Read return Mal.T_Array with Inline;
|
||||
|
||||
function Eval (Ast0 : in Mal.T;
|
||||
Env0 : in Envs.Ptr) return Mal.T;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||
-- The built-in variant needs to see the Repl variable.
|
||||
|
||||
function Quasiquote (Ast : in Mal.T;
|
||||
Env : in Envs.Ptr) return Mal.T;
|
||||
@ -46,7 +45,6 @@ procedure Step7_Quote is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -62,7 +60,7 @@ procedure Step7_Quote is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
First : Mal.T;
|
||||
begin
|
||||
<<Restart>>
|
||||
@ -70,94 +68,103 @@ procedure Step7_Quote is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||
elsif First.Symbol = Symbols.Names.Quote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence (2);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence.all (2);
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -176,24 +183,24 @@ procedure Step7_Quote is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when others =>
|
||||
@ -225,46 +232,56 @@ procedure Step7_Quote is
|
||||
Env : in Envs.Ptr) return Mal.T
|
||||
is
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||
with Inline;
|
||||
-- Handle vectors and lists not starting with unquote.
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
||||
-- The final return concatenates these lists.
|
||||
R : Mal.T_Array (1 .. List.Length);
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||
Vector : Vectors.Vector; -- buffer for concatenation
|
||||
Sequence : Mal.Sequence_Ptr;
|
||||
Tmp : Mal.T;
|
||||
begin
|
||||
for I in R'Range loop
|
||||
R (I) := List (I);
|
||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
||||
Symbols.Names.Splice_Unquote)
|
||||
for I in 1 .. List.Length loop
|
||||
if List (I).Kind in Kind_List
|
||||
and then 0 < List (I).Sequence.all.Length
|
||||
and then List (I).Sequence.all (1)
|
||||
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||
then
|
||||
Err.Check (R (I).Sequence.Length = 2,
|
||||
Err.Check (List (I).Sequence.all.Length = 2,
|
||||
"splice-unquote expects 1 parameter");
|
||||
R (I) := Eval (@.Sequence (2), Env);
|
||||
Err.Check (R (I).Kind = Kind_List,
|
||||
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||
Err.Check (Tmp.Kind = Kind_List,
|
||||
"splice_unquote expects a list");
|
||||
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||
Vector.Append (Tmp.Sequence.all (I));
|
||||
end loop;
|
||||
else
|
||||
R (I) := Sequences.List
|
||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
||||
Vector.Append (Quasiquote (List (I), Env));
|
||||
end if;
|
||||
end loop;
|
||||
return Sequences.Concat (R);
|
||||
-- Now that we know the number of elements, convert to a list.
|
||||
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||
for I in 1 .. Natural (Vector.Length) loop
|
||||
Sequence.Replace_Element (I, Vector (I));
|
||||
end loop;
|
||||
return (Kind_List, Sequence);
|
||||
end Quasiquote_List;
|
||||
|
||||
begin -- Quasiquote
|
||||
case Ast.Kind is
|
||||
when Kind_Vector =>
|
||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
when Kind_List =>
|
||||
if 0 < Ast.Sequence.Length
|
||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
||||
if 0 < Ast.Sequence.all.Length
|
||||
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||
Symbols.Names.Unquote)
|
||||
then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
else
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
end if;
|
||||
when others =>
|
||||
return Ast;
|
||||
@ -291,27 +308,37 @@ procedure Step7_Quote is
|
||||
:= "(def! not (fn* (a) (if a false true)))"
|
||||
& "(def! load-file (fn* (f)"
|
||||
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||
end Eval_Builtin;
|
||||
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||
Argv : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Define ARGV from command line arguments.
|
||||
declare
|
||||
use Ada.Command_Line;
|
||||
Args : Mal.T_Array (2 .. Argument_Count);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
||||
if Script then
|
||||
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||
for I in 2 .. ACL.Argument_Count loop
|
||||
Argv.all.Replace_Element
|
||||
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||
end loop;
|
||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
||||
end;
|
||||
-- Script?
|
||||
if 0 < Ada.Command_Line.Argument_Count then
|
||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
||||
else
|
||||
Argv := Sequences.Constructor (0);
|
||||
end if;
|
||||
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||
-- Execute user commands.
|
||||
if Script then
|
||||
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||
else
|
||||
loop
|
||||
begin
|
||||
@ -323,16 +350,17 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
end if;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step7_Quote;
|
||||
|
@ -1,4 +1,5 @@
|
||||
with Ada.Command_Line;
|
||||
with Ada.Containers.Vectors;
|
||||
with Ada.Environment_Variables;
|
||||
with Ada.Strings.Unbounded;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
@ -7,11 +8,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step8_Macros is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
package ACL renames Ada.Command_Line;
|
||||
package ASU renames Ada.Strings.Unbounded;
|
||||
|
||||
function Read return Mal.T_Array with Inline;
|
||||
|
||||
function Eval (Ast0 : in Mal.T;
|
||||
Env0 : in Envs.Ptr) return Mal.T;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||
-- The built-in variant needs to see the Repl variable.
|
||||
|
||||
function Quasiquote (Ast : in Mal.T;
|
||||
Env : in Envs.Ptr) return Mal.T;
|
||||
@ -46,7 +45,6 @@ procedure Step8_Macros is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -62,7 +60,7 @@ procedure Step8_Macros is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
Macroexpanding : Boolean := False;
|
||||
First : Mal.T;
|
||||
begin
|
||||
@ -71,111 +69,120 @@ procedure Step8_Macros is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
declare
|
||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
||||
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||
begin
|
||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||
return R : constant Mal.T := F.Fn.New_Macro do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
end;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
Macroexpanding := True;
|
||||
Ast := Ast.Sequence (2);
|
||||
Ast := Ast.Sequence.all (2);
|
||||
goto Restart;
|
||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||
elsif First.Symbol = Symbols.Names.Quote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence (2);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence.all (2);
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -194,42 +201,43 @@ procedure Step8_Macros is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when Kind_Macro =>
|
||||
declare
|
||||
Args : constant Mal.T_Array
|
||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
||||
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||
begin
|
||||
if Macroexpanding then
|
||||
-- Evaluate the macro with tail call optimization.
|
||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
else
|
||||
-- Evaluate the macro normally.
|
||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
||||
(Outer => Env,
|
||||
Binds => First.Fn.Params,
|
||||
Ast := Eval (First.Fn.all.Ast,
|
||||
Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args));
|
||||
-- Then evaluate the result with TCO.
|
||||
goto Restart;
|
||||
@ -268,46 +276,56 @@ procedure Step8_Macros is
|
||||
Env : in Envs.Ptr) return Mal.T
|
||||
is
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||
with Inline;
|
||||
-- Handle vectors and lists not starting with unquote.
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
||||
-- The final return concatenates these lists.
|
||||
R : Mal.T_Array (1 .. List.Length);
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||
Vector : Vectors.Vector; -- buffer for concatenation
|
||||
Sequence : Mal.Sequence_Ptr;
|
||||
Tmp : Mal.T;
|
||||
begin
|
||||
for I in R'Range loop
|
||||
R (I) := List (I);
|
||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
||||
Symbols.Names.Splice_Unquote)
|
||||
for I in 1 .. List.Length loop
|
||||
if List (I).Kind in Kind_List
|
||||
and then 0 < List (I).Sequence.all.Length
|
||||
and then List (I).Sequence.all (1)
|
||||
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||
then
|
||||
Err.Check (R (I).Sequence.Length = 2,
|
||||
Err.Check (List (I).Sequence.all.Length = 2,
|
||||
"splice-unquote expects 1 parameter");
|
||||
R (I) := Eval (@.Sequence (2), Env);
|
||||
Err.Check (R (I).Kind = Kind_List,
|
||||
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||
Err.Check (Tmp.Kind = Kind_List,
|
||||
"splice_unquote expects a list");
|
||||
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||
Vector.Append (Tmp.Sequence.all (I));
|
||||
end loop;
|
||||
else
|
||||
R (I) := Sequences.List
|
||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
||||
Vector.Append (Quasiquote (List (I), Env));
|
||||
end if;
|
||||
end loop;
|
||||
return Sequences.Concat (R);
|
||||
-- Now that we know the number of elements, convert to a list.
|
||||
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||
for I in 1 .. Natural (Vector.Length) loop
|
||||
Sequence.Replace_Element (I, Vector (I));
|
||||
end loop;
|
||||
return (Kind_List, Sequence);
|
||||
end Quasiquote_List;
|
||||
|
||||
begin -- Quasiquote
|
||||
case Ast.Kind is
|
||||
when Kind_Vector =>
|
||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
when Kind_List =>
|
||||
if 0 < Ast.Sequence.Length
|
||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
||||
if 0 < Ast.Sequence.all.Length
|
||||
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||
Symbols.Names.Unquote)
|
||||
then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
else
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
end if;
|
||||
when others =>
|
||||
return Ast;
|
||||
@ -345,27 +363,37 @@ procedure Step8_Macros is
|
||||
& " (if (= 1 (count xs)) (first xs)"
|
||||
& " `(let* (or_FIXME ~(first xs))"
|
||||
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||
end Eval_Builtin;
|
||||
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||
Argv : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Define ARGV from command line arguments.
|
||||
declare
|
||||
use Ada.Command_Line;
|
||||
Args : Mal.T_Array (2 .. Argument_Count);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
||||
if Script then
|
||||
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||
for I in 2 .. ACL.Argument_Count loop
|
||||
Argv.all.Replace_Element
|
||||
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||
end loop;
|
||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
||||
end;
|
||||
-- Script?
|
||||
if 0 < Ada.Command_Line.Argument_Count then
|
||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
||||
else
|
||||
Argv := Sequences.Constructor (0);
|
||||
end if;
|
||||
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||
-- Execute user commands.
|
||||
if Script then
|
||||
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||
else
|
||||
loop
|
||||
begin
|
||||
@ -377,16 +405,17 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
end if;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step8_Macros;
|
||||
|
@ -1,4 +1,5 @@
|
||||
with Ada.Command_Line;
|
||||
with Ada.Containers.Vectors;
|
||||
with Ada.Environment_Variables;
|
||||
with Ada.Strings.Unbounded;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
@ -7,11 +8,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
with Types.Maps;
|
||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure Step9_Try is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
package ACL renames Ada.Command_Line;
|
||||
package ASU renames Ada.Strings.Unbounded;
|
||||
|
||||
function Read return Mal.T_Array with Inline;
|
||||
|
||||
function Eval (Ast0 : in Mal.T;
|
||||
Env0 : in Envs.Ptr) return Mal.T;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||
-- The built-in variant needs to see the Repl variable.
|
||||
|
||||
function Quasiquote (Ast : in Mal.T;
|
||||
Env : in Envs.Ptr) return Mal.T;
|
||||
@ -46,7 +45,6 @@ procedure Step9_Try is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -62,7 +60,7 @@ procedure Step9_Try is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
Macroexpanding : Boolean := False;
|
||||
First : Mal.T;
|
||||
begin
|
||||
@ -71,137 +69,149 @@ procedure Step9_Try is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
declare
|
||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
||||
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||
begin
|
||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||
return R : constant Mal.T := F.Fn.New_Macro do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
end;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
Macroexpanding := True;
|
||||
Ast := Ast.Sequence (2);
|
||||
Ast := Ast.Sequence.all (2);
|
||||
goto Restart;
|
||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||
elsif First.Symbol = Symbols.Names.Quote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence (2);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence.all (2);
|
||||
elsif First.Symbol = Symbols.Names.Try then
|
||||
if Ast.Sequence.Length = 2 then
|
||||
Ast := Ast.Sequence (2);
|
||||
if Ast.Sequence.all.Length = 2 then
|
||||
Ast := Ast.Sequence.all (2);
|
||||
goto Restart;
|
||||
end if;
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
|
||||
Err.Check (Ast.Sequence (3).Kind = Kind_List,
|
||||
Err.Check (Ast.Sequence.all.Length = 3,
|
||||
"expected 1 or 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
|
||||
"parameter 2 must be a list");
|
||||
declare
|
||||
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
|
||||
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
|
||||
begin
|
||||
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
|
||||
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||
Err.Check (A3.all.Length = 3,
|
||||
"length of parameter 2 must be 3");
|
||||
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||
"parameter 3 must start with 'catch*'");
|
||||
Err.Check (A3 (2).Kind = Kind_Symbol,
|
||||
Err.Check (A3.all (2).Kind = Kind_Symbol,
|
||||
"a symbol must follow catch*");
|
||||
begin
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
exception
|
||||
when Err.Error =>
|
||||
Env.Replace_With_Sub;
|
||||
Env.Set (A3 (2).Symbol, Err.Data);
|
||||
Ast := A3 (3);
|
||||
goto Restart;
|
||||
null;
|
||||
end;
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
Env.all.Set (A3.all (2).Symbol, Err.Data);
|
||||
Ast := A3.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -220,42 +230,43 @@ procedure Step9_Try is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when Kind_Macro =>
|
||||
declare
|
||||
Args : constant Mal.T_Array
|
||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
||||
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||
begin
|
||||
if Macroexpanding then
|
||||
-- Evaluate the macro with tail call optimization.
|
||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
else
|
||||
-- Evaluate the macro normally.
|
||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
||||
(Outer => Env,
|
||||
Binds => First.Fn.Params,
|
||||
Ast := Eval (First.Fn.all.Ast,
|
||||
Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args));
|
||||
-- Then evaluate the result with TCO.
|
||||
goto Restart;
|
||||
@ -294,46 +305,56 @@ procedure Step9_Try is
|
||||
Env : in Envs.Ptr) return Mal.T
|
||||
is
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||
with Inline;
|
||||
-- Handle vectors and lists not starting with unquote.
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
||||
-- The final return concatenates these lists.
|
||||
R : Mal.T_Array (1 .. List.Length);
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||
Vector : Vectors.Vector; -- buffer for concatenation
|
||||
Sequence : Mal.Sequence_Ptr;
|
||||
Tmp : Mal.T;
|
||||
begin
|
||||
for I in R'Range loop
|
||||
R (I) := List (I);
|
||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
||||
Symbols.Names.Splice_Unquote)
|
||||
for I in 1 .. List.Length loop
|
||||
if List (I).Kind in Kind_List
|
||||
and then 0 < List (I).Sequence.all.Length
|
||||
and then List (I).Sequence.all (1)
|
||||
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||
then
|
||||
Err.Check (R (I).Sequence.Length = 2,
|
||||
Err.Check (List (I).Sequence.all.Length = 2,
|
||||
"splice-unquote expects 1 parameter");
|
||||
R (I) := Eval (@.Sequence (2), Env);
|
||||
Err.Check (R (I).Kind = Kind_List,
|
||||
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||
Err.Check (Tmp.Kind = Kind_List,
|
||||
"splice_unquote expects a list");
|
||||
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||
Vector.Append (Tmp.Sequence.all (I));
|
||||
end loop;
|
||||
else
|
||||
R (I) := Sequences.List
|
||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
||||
Vector.Append (Quasiquote (List (I), Env));
|
||||
end if;
|
||||
end loop;
|
||||
return Sequences.Concat (R);
|
||||
-- Now that we know the number of elements, convert to a list.
|
||||
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||
for I in 1 .. Natural (Vector.Length) loop
|
||||
Sequence.Replace_Element (I, Vector (I));
|
||||
end loop;
|
||||
return (Kind_List, Sequence);
|
||||
end Quasiquote_List;
|
||||
|
||||
begin -- Quasiquote
|
||||
case Ast.Kind is
|
||||
when Kind_Vector =>
|
||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
when Kind_List =>
|
||||
if 0 < Ast.Sequence.Length
|
||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
||||
if 0 < Ast.Sequence.all.Length
|
||||
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||
Symbols.Names.Unquote)
|
||||
then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
else
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
end if;
|
||||
when others =>
|
||||
return Ast;
|
||||
@ -371,27 +392,37 @@ procedure Step9_Try is
|
||||
& " (if (= 1 (count xs)) (first xs)"
|
||||
& " `(let* (or_FIXME ~(first xs))"
|
||||
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||
end Eval_Builtin;
|
||||
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||
Argv : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Define ARGV from command line arguments.
|
||||
declare
|
||||
use Ada.Command_Line;
|
||||
Args : Mal.T_Array (2 .. Argument_Count);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
||||
if Script then
|
||||
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||
for I in 2 .. ACL.Argument_Count loop
|
||||
Argv.all.Replace_Element
|
||||
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||
end loop;
|
||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
||||
end;
|
||||
-- Script?
|
||||
if 0 < Ada.Command_Line.Argument_Count then
|
||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
||||
else
|
||||
Argv := Sequences.Constructor (0);
|
||||
end if;
|
||||
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||
-- Execute user commands.
|
||||
if Script then
|
||||
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||
else
|
||||
loop
|
||||
begin
|
||||
@ -403,16 +434,17 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
end if;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end Step9_Try;
|
||||
|
@ -1,4 +1,5 @@
|
||||
with Ada.Command_Line;
|
||||
with Ada.Containers.Vectors;
|
||||
with Ada.Environment_Variables;
|
||||
with Ada.Strings.Unbounded;
|
||||
with Ada.Text_IO.Unbounded_IO;
|
||||
@ -7,10 +8,10 @@ with Core;
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Garbage_Collected;
|
||||
with Printer;
|
||||
with Reader;
|
||||
with Readline;
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Mal;
|
||||
@ -20,20 +21,19 @@ with Types.Symbols.Names;
|
||||
|
||||
procedure StepA_Mal is
|
||||
|
||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
||||
Dbgenv0 : constant Boolean
|
||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
||||
Dbgeval : constant Boolean
|
||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
||||
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||
|
||||
use Types;
|
||||
use type Mal.T;
|
||||
package ACL renames Ada.Command_Line;
|
||||
package ASU renames Ada.Strings.Unbounded;
|
||||
|
||||
function Read return Mal.T_Array with Inline;
|
||||
|
||||
function Eval (Ast0 : in Mal.T;
|
||||
Env0 : in Envs.Ptr) return Mal.T;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||
-- The built-in variant needs to see the Repl variable.
|
||||
|
||||
function Quasiquote (Ast : in Mal.T;
|
||||
Env : in Envs.Ptr) return Mal.T;
|
||||
@ -46,7 +46,6 @@ procedure StepA_Mal is
|
||||
|
||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||
|
||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||
|
||||
procedure Exec (Script : in String;
|
||||
@ -62,7 +61,7 @@ procedure StepA_Mal is
|
||||
-- Use local variables, that can be rewritten when tail call
|
||||
-- optimization goes to <<Restart>>.
|
||||
Ast : Mal.T := Ast0;
|
||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
||||
Env : Envs.Ptr := Env0;
|
||||
Macroexpanding : Boolean := False;
|
||||
First : Mal.T;
|
||||
begin
|
||||
@ -71,137 +70,149 @@ procedure StepA_Mal is
|
||||
Ada.Text_IO.New_Line;
|
||||
Ada.Text_IO.Put ("EVAL: ");
|
||||
Print (Ast);
|
||||
if Dbgenv0 then
|
||||
Envs.Dump_Stack (Long => Dbgenv1);
|
||||
end if;
|
||||
Envs.Dump_Stack (Env.all);
|
||||
end if;
|
||||
|
||||
case Ast.Kind is
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
return Ast;
|
||||
when Kind_Symbol =>
|
||||
return Env.Get (Ast.Symbol);
|
||||
return Env.all.Get (Ast.Symbol);
|
||||
when Kind_Map =>
|
||||
return Eval_Map_Elts (Ast.Map, Env);
|
||||
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||
when Kind_Vector =>
|
||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
||||
declare
|
||||
Len : constant Natural := Ast.Sequence.all.Length;
|
||||
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||
begin
|
||||
for I in 1 .. Len loop
|
||||
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||
end loop;
|
||||
return (Kind_Vector, List);
|
||||
end;
|
||||
when Kind_List =>
|
||||
null;
|
||||
end case;
|
||||
|
||||
-- Ast is a list.
|
||||
if Ast.Sequence.Length = 0 then
|
||||
if Ast.Sequence.all.Length = 0 then
|
||||
return Ast;
|
||||
end if;
|
||||
First := Ast.Sequence (1);
|
||||
First := Ast.Sequence.all (1);
|
||||
|
||||
-- Special forms
|
||||
-- Ast is a non-empty list, First is its first element.
|
||||
case First.Kind is
|
||||
when Kind_Symbol =>
|
||||
if First.Symbol = Symbols.Names.Def then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||
"parameter 1 must be a symbol");
|
||||
declare
|
||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
||||
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||
begin
|
||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||
return R : constant Mal.T := F.Fn.New_Macro do
|
||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
||||
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||
end return;
|
||||
end;
|
||||
-- do is a built-in function, shortening this test cascade.
|
||||
elsif First.Symbol = Symbols.Names.Fn then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
||||
Ast => Ast.Sequence (3),
|
||||
Env => Env.New_Closure);
|
||||
return Fns.New_Function
|
||||
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||
Ast => Ast.Sequence.all (3),
|
||||
Env => Env);
|
||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
||||
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||
"expected 2 or 3 parameters");
|
||||
declare
|
||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
||||
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||
begin
|
||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
elsif Ast.Sequence.Length = 3 then
|
||||
elsif Ast.Sequence.all.Length = 3 then
|
||||
return Mal.Nil;
|
||||
else
|
||||
Ast := Ast.Sequence (4);
|
||||
Ast := Ast.Sequence.all (4);
|
||||
goto Restart;
|
||||
end if;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Let then
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
||||
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||
"parameter 1 must be a sequence");
|
||||
declare
|
||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
||||
Bindings : constant Mal.Sequence_Ptr
|
||||
:= Ast.Sequence.all (2).Sequence;
|
||||
begin
|
||||
Err.Check (Bindings.Length mod 2 = 0,
|
||||
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||
"parameter 1 must have an even length");
|
||||
Env.Replace_With_Sub;
|
||||
for I in 1 .. Bindings.Length / 2 loop
|
||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
for I in 1 .. Bindings.all.Length / 2 loop
|
||||
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||
"binding keys must be symbols");
|
||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
||||
Eval (Bindings (2 * I), Env));
|
||||
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||
Eval (Bindings.all (2 * I), Env));
|
||||
end loop;
|
||||
Ast := Ast.Sequence (3);
|
||||
Ast := Ast.Sequence.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
Macroexpanding := True;
|
||||
Ast := Ast.Sequence (2);
|
||||
Ast := Ast.Sequence.all (2);
|
||||
goto Restart;
|
||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||
elsif First.Symbol = Symbols.Names.Quote then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence (2);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Ast.Sequence.all (2);
|
||||
elsif First.Symbol = Symbols.Names.Try then
|
||||
if Ast.Sequence.Length = 2 then
|
||||
Ast := Ast.Sequence (2);
|
||||
if Ast.Sequence.all.Length = 2 then
|
||||
Ast := Ast.Sequence.all (2);
|
||||
goto Restart;
|
||||
end if;
|
||||
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
|
||||
Err.Check (Ast.Sequence (3).Kind = Kind_List,
|
||||
Err.Check (Ast.Sequence.all.Length = 3,
|
||||
"expected 1 or 2 parameters");
|
||||
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
|
||||
"parameter 2 must be a list");
|
||||
declare
|
||||
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
|
||||
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
|
||||
begin
|
||||
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
|
||||
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||
Err.Check (A3.all.Length = 3,
|
||||
"length of parameter 2 must be 3");
|
||||
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||
"parameter 3 must start with 'catch*'");
|
||||
Err.Check (A3 (2).Kind = Kind_Symbol,
|
||||
Err.Check (A3.all (2).Kind = Kind_Symbol,
|
||||
"a symbol must follow catch*");
|
||||
begin
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
exception
|
||||
when Err.Error =>
|
||||
Env.Replace_With_Sub;
|
||||
Env.Set (A3 (2).Symbol, Err.Data);
|
||||
Ast := A3 (3);
|
||||
goto Restart;
|
||||
null;
|
||||
end;
|
||||
Env := Envs.New_Env (Outer => Env);
|
||||
Env.all.Set (A3.all (2).Symbol, Err.Data);
|
||||
Ast := A3.all (3);
|
||||
goto Restart;
|
||||
end;
|
||||
else
|
||||
-- Equivalent to First := Eval (First, Env)
|
||||
-- except that we already know enough to spare a recursive call.
|
||||
First := Env.Get (First.Symbol);
|
||||
First := Env.all.Get (First.Symbol);
|
||||
end if;
|
||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||
| Kind_Macro | Kind_Function =>
|
||||
@ -220,51 +231,52 @@ procedure StepA_Mal is
|
||||
case First.Kind is
|
||||
when Kind_Builtin =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Builtin_With_Meta =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
return First.Builtin_With_Meta.Builtin.all (Args);
|
||||
return First.Builtin_With_Meta.all.Builtin.all (Args);
|
||||
end;
|
||||
when Kind_Fn =>
|
||||
declare
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
||||
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
||||
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||
end loop;
|
||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
||||
Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
end;
|
||||
when Kind_Macro =>
|
||||
declare
|
||||
Args : constant Mal.T_Array
|
||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
||||
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||
begin
|
||||
if Macroexpanding then
|
||||
-- Evaluate the macro with tail call optimization.
|
||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
||||
Env := Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args);
|
||||
Ast := First.Fn.Ast;
|
||||
Ast := First.Fn.all.Ast;
|
||||
goto Restart;
|
||||
else
|
||||
-- Evaluate the macro normally.
|
||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
||||
(Outer => Env,
|
||||
Binds => First.Fn.Params,
|
||||
Ast := Eval (First.Fn.all.Ast,
|
||||
Envs.New_Env (Outer => Env,
|
||||
Binds => First.Fn.all.Params,
|
||||
Exprs => Args));
|
||||
-- Then evaluate the result with TCO.
|
||||
goto Restart;
|
||||
@ -303,46 +315,56 @@ procedure StepA_Mal is
|
||||
Env : in Envs.Ptr) return Mal.T
|
||||
is
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||
with Inline;
|
||||
-- Handle vectors and lists not starting with unquote.
|
||||
|
||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
||||
-- The final return concatenates these lists.
|
||||
R : Mal.T_Array (1 .. List.Length);
|
||||
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||
Vector : Vectors.Vector; -- buffer for concatenation
|
||||
Sequence : Mal.Sequence_Ptr;
|
||||
Tmp : Mal.T;
|
||||
begin
|
||||
for I in R'Range loop
|
||||
R (I) := List (I);
|
||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
||||
Symbols.Names.Splice_Unquote)
|
||||
for I in 1 .. List.Length loop
|
||||
if List (I).Kind in Kind_List
|
||||
and then 0 < List (I).Sequence.all.Length
|
||||
and then List (I).Sequence.all (1)
|
||||
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||
then
|
||||
Err.Check (R (I).Sequence.Length = 2,
|
||||
Err.Check (List (I).Sequence.all.Length = 2,
|
||||
"splice-unquote expects 1 parameter");
|
||||
R (I) := Eval (@.Sequence (2), Env);
|
||||
Err.Check (R (I).Kind = Kind_List,
|
||||
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||
Err.Check (Tmp.Kind = Kind_List,
|
||||
"splice_unquote expects a list");
|
||||
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||
Vector.Append (Tmp.Sequence.all (I));
|
||||
end loop;
|
||||
else
|
||||
R (I) := Sequences.List
|
||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
||||
Vector.Append (Quasiquote (List (I), Env));
|
||||
end if;
|
||||
end loop;
|
||||
return Sequences.Concat (R);
|
||||
-- Now that we know the number of elements, convert to a list.
|
||||
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||
for I in 1 .. Natural (Vector.Length) loop
|
||||
Sequence.Replace_Element (I, Vector (I));
|
||||
end loop;
|
||||
return (Kind_List, Sequence);
|
||||
end Quasiquote_List;
|
||||
|
||||
begin -- Quasiquote
|
||||
case Ast.Kind is
|
||||
when Kind_Vector =>
|
||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
when Kind_List =>
|
||||
if 0 < Ast.Sequence.Length
|
||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
||||
if 0 < Ast.Sequence.all.Length
|
||||
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||
Symbols.Names.Unquote)
|
||||
then
|
||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence (2), Env);
|
||||
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||
return Eval (Ast.Sequence.all (2), Env);
|
||||
else
|
||||
return Quasiquote_List (Ast.Sequence);
|
||||
return Quasiquote_List (Ast.Sequence.all);
|
||||
end if;
|
||||
when others =>
|
||||
return Ast;
|
||||
@ -385,27 +407,37 @@ procedure StepA_Mal is
|
||||
& " `(let* (~condvar ~(first xs))"
|
||||
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
||||
& "(def! *host-language* ""ada.2"")";
|
||||
Repl : Envs.Ptr renames Envs.Repl;
|
||||
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||
end Eval_Builtin;
|
||||
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||
Argv : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Show the Eval function to other packages.
|
||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||
-- Add Core functions into the top environment.
|
||||
Core.NS_Add_To_Repl;
|
||||
Core.NS_Add_To_Repl (Repl);
|
||||
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||
-- Native startup procedure.
|
||||
Exec (Startup, Repl);
|
||||
-- Define ARGV from command line arguments.
|
||||
declare
|
||||
use Ada.Command_Line;
|
||||
Args : Mal.T_Array (2 .. Argument_Count);
|
||||
begin
|
||||
for I in Args'Range loop
|
||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
||||
if Script then
|
||||
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||
for I in 2 .. ACL.Argument_Count loop
|
||||
Argv.all.Replace_Element
|
||||
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||
end loop;
|
||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
||||
end;
|
||||
-- Script?
|
||||
if 0 < Ada.Command_Line.Argument_Count then
|
||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
||||
else
|
||||
Argv := Sequences.Constructor (0);
|
||||
end if;
|
||||
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||
-- Execute user commands.
|
||||
if Script then
|
||||
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||
else
|
||||
Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl);
|
||||
loop
|
||||
@ -418,16 +450,17 @@ begin
|
||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||
end;
|
||||
-- Other exceptions are really unexpected.
|
||||
|
||||
-- Collect garbage.
|
||||
Err.Data := Mal.Nil;
|
||||
Repl.all.Keep;
|
||||
Garbage_Collected.Clean;
|
||||
end loop;
|
||||
Ada.Text_IO.New_Line;
|
||||
end if;
|
||||
|
||||
-- If assertions are enabled, check deallocations.
|
||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
||||
pragma Debug (Atoms.Check_Allocations);
|
||||
pragma Debug (Builtins.Check_Allocations);
|
||||
pragma Debug (Fns.Check_Allocations);
|
||||
pragma Debug (Maps.Check_Allocations);
|
||||
pragma Debug (Sequences.Check_Allocations);
|
||||
pragma Debug (Symbols.Check_Allocations);
|
||||
pragma Debug (Garbage_Collected.Clean);
|
||||
Garbage_Collected.Check_Allocations;
|
||||
Symbols.Check_Allocations;
|
||||
end StepA_Mal;
|
||||
|
@ -1,68 +1,41 @@
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Err;
|
||||
with Types.Mal;
|
||||
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
|
||||
package body Types.Atoms is
|
||||
|
||||
type Rec is limited record
|
||||
Refs : Natural;
|
||||
Data : Mal.T;
|
||||
end record;
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end Adjust;
|
||||
|
||||
function Atom (Args : in Mal.T_Array) return Mal.T is
|
||||
Ref : Mal.Atom_Ptr;
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
Allocations := Allocations + 1;
|
||||
return (Kind_Atom, (Ada.Finalization.Controlled with new Rec'
|
||||
(Refs => 1,
|
||||
Data => Args (Args'First))));
|
||||
Ref := new Instance'(Garbage_Collected.Instance with
|
||||
Data => Args (Args'First));
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return (Kind_Atom, Ref);
|
||||
end Atom;
|
||||
|
||||
procedure Check_Allocations is
|
||||
begin
|
||||
pragma Assert (Allocations = 0);
|
||||
end Check_Allocations;
|
||||
|
||||
function Deref (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom");
|
||||
return Args (Args'First).Atom.Ref.all.Data;
|
||||
return Args (Args'First).Atom.all.Data;
|
||||
end Deref;
|
||||
|
||||
function Deref (Item : in Ptr) return Mal.T
|
||||
is (Item.Ref.all.Data);
|
||||
function Deref (Item : in Instance) return Mal.T
|
||||
is (Item.Data);
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
Object.Ref.all.Refs := @ - 1;
|
||||
if 0 < Object.Ref.all.Refs then
|
||||
Object.Ref := null;
|
||||
else
|
||||
Allocations := Allocations - 1;
|
||||
Free (Object.Ref);
|
||||
end if;
|
||||
end if;
|
||||
end Finalize;
|
||||
Mal.Keep (Object.Data);
|
||||
end Keep_References;
|
||||
|
||||
function Reset (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 2, "expected 2 parameters");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Atom,
|
||||
"parameter 1 must be an atom");
|
||||
Args (Args'First).Atom.Ref.all.Data := Args (Args'Last);
|
||||
Args (Args'First).Atom.all.Data := Args (Args'Last);
|
||||
return Args (Args'Last);
|
||||
end Reset;
|
||||
|
||||
@ -73,7 +46,7 @@ package body Types.Atoms is
|
||||
"parameter 1 must be an atom");
|
||||
declare
|
||||
use type Mal.T_Array;
|
||||
X : Mal.T renames Args (Args'First).Atom.Ref.all.Data;
|
||||
X : Mal.T renames Args (Args'First).Atom.all.Data;
|
||||
F : Mal.T renames Args (Args'First + 1);
|
||||
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
|
||||
begin
|
||||
@ -81,9 +54,9 @@ package body Types.Atoms is
|
||||
when Kind_Builtin =>
|
||||
X := F.Builtin.all (A);
|
||||
when Kind_Builtin_With_Meta =>
|
||||
X := F.Builtin_With_Meta.Builtin.all (A);
|
||||
X := F.Builtin_With_Meta.all.Builtin.all (A);
|
||||
when Kind_Fn =>
|
||||
X := F.Fn.Apply (A);
|
||||
X := F.Fn.all.Apply (A);
|
||||
when others =>
|
||||
Err.Raise_With ("parameter 2 must be a function");
|
||||
end case;
|
||||
|
@ -1,10 +1,9 @@
|
||||
private with Ada.Finalization;
|
||||
|
||||
limited with Types.Mal;
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
|
||||
package Types.Atoms is
|
||||
|
||||
type Ptr is private;
|
||||
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||
|
||||
-- Built-in functions.
|
||||
function Atom (Args : in Mal.T_Array) return Mal.T;
|
||||
@ -13,21 +12,13 @@ package Types.Atoms is
|
||||
function Swap (Args : in Mal.T_Array) return Mal.T;
|
||||
|
||||
-- Helper for print.
|
||||
function Deref (Item : in Ptr) return Mal.T with Inline;
|
||||
|
||||
-- Debug.
|
||||
procedure Check_Allocations;
|
||||
function Deref (Item : in Instance) return Mal.T with Inline;
|
||||
|
||||
private
|
||||
|
||||
type Rec;
|
||||
type Acc is access Rec;
|
||||
type Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Acc := null;
|
||||
end record
|
||||
with Invariant => Ptr.Ref /= null;
|
||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
type Instance is new Garbage_Collected.Instance with record
|
||||
Data : Mal.T;
|
||||
end record;
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Types.Atoms;
|
||||
|
@ -1,63 +1,30 @@
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Types.Mal;
|
||||
|
||||
package body Types.Builtins is
|
||||
|
||||
type Rec is limited record
|
||||
Builtin : Mal.Builtin_Ptr;
|
||||
Refs : Natural;
|
||||
Meta : Mal.T;
|
||||
end record;
|
||||
function Builtin (Item : in Instance) return Mal.Builtin_Ptr
|
||||
is (Item.F_Builtin);
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end Adjust;
|
||||
Mal.Keep (Object.F_Meta);
|
||||
end Keep_References;
|
||||
|
||||
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr
|
||||
is (Item.Ref.all.Builtin);
|
||||
|
||||
procedure Check_Allocations is
|
||||
begin
|
||||
pragma Assert (Allocations = 0);
|
||||
end Check_Allocations;
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
Object.Ref.all.Refs := @ - 1;
|
||||
if 0 < Object.Ref.all.Refs then
|
||||
Object.Ref := null;
|
||||
else
|
||||
Allocations := Allocations - 1;
|
||||
Free (Object.Ref);
|
||||
end if;
|
||||
end if;
|
||||
end Finalize;
|
||||
|
||||
function Meta (Item : in Ptr) return Mal.T
|
||||
is (Item.Ref.all.Meta);
|
||||
function Meta (Item : in Instance) return Mal.T
|
||||
is (Item.F_Meta);
|
||||
|
||||
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
||||
Metadata : in Mal.T) return Mal.T is
|
||||
Metadata : in Mal.T) return Mal.T
|
||||
is
|
||||
Ref : constant Mal.Builtin_With_Meta_Ptr
|
||||
:= new Instance'(Garbage_Collected.Instance with
|
||||
F_Builtin => Builtin,
|
||||
F_Meta => Metadata);
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
return (Kind_Builtin_With_Meta,
|
||||
(Ada.Finalization.Controlled with new Rec'(Builtin => Builtin,
|
||||
Meta => Metadata,
|
||||
Refs => 1)));
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return (Kind_Builtin_With_Meta, Ref);
|
||||
end With_Meta;
|
||||
|
||||
function With_Meta (Item : in Ptr;
|
||||
function With_Meta (Item : in Instance;
|
||||
Metadata : in Mal.T) return Mal.T
|
||||
-- Do not try to reuse the memory. We can hope that this kind of
|
||||
-- nonsense will be rare.
|
||||
is (With_Meta (Item.Ref.all.Builtin, Metadata));
|
||||
is (With_Meta (Item.Builtin, Metadata));
|
||||
|
||||
end Types.Builtins;
|
||||
|
@ -1,6 +1,5 @@
|
||||
private with Ada.Finalization;
|
||||
|
||||
limited with Types.Mal;
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
|
||||
package Types.Builtins is
|
||||
|
||||
@ -9,27 +8,21 @@ package Types.Builtins is
|
||||
-- functions. The controlled type below is only useful when one
|
||||
-- has the silly idea to add metadata to a built-in.
|
||||
|
||||
type Ptr is tagged private;
|
||||
type Instance is new Garbage_Collected.Instance with private;
|
||||
|
||||
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
||||
Metadata : in Mal.T) return Mal.T with Inline;
|
||||
function With_Meta (Item : in Ptr;
|
||||
function With_Meta (Item : in Instance;
|
||||
Metadata : in Mal.T) return Mal.T with Inline;
|
||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
||||
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline;
|
||||
|
||||
procedure Check_Allocations;
|
||||
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||
function Builtin (Item : in Instance) return Mal.Builtin_Ptr with Inline;
|
||||
|
||||
private
|
||||
|
||||
type Rec;
|
||||
type Acc is access Rec;
|
||||
type Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Acc := null;
|
||||
end record
|
||||
with Invariant => Ptr.Ref /= null;
|
||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
type Instance is new Garbage_Collected.Instance with record
|
||||
F_Builtin : Mal.Builtin_Ptr;
|
||||
F_Meta : Mal.T;
|
||||
end record;
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Types.Builtins;
|
||||
|
@ -1,144 +1,86 @@
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Envs;
|
||||
with Err;
|
||||
with Eval_Cb;
|
||||
with Types.Mal;
|
||||
with Types.Sequences;
|
||||
with Types.Symbols;
|
||||
|
||||
package body Types.Fns is
|
||||
|
||||
subtype AFC is Ada.Finalization.Controlled;
|
||||
use type Envs.Closure_Ptr;
|
||||
|
||||
type Rec (Params_Last : Natural) is limited record
|
||||
Ast : Mal.T;
|
||||
Refs : Natural := 1;
|
||||
Env : Envs.Closure_Ptr := Envs.Null_Closure;
|
||||
Meta : Mal.T := Mal.Nil;
|
||||
Params : Symbols.Symbol_Array (1 .. Params_Last);
|
||||
end record;
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
use type Envs.Ptr;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end Adjust;
|
||||
function Apply (Item : in Instance;
|
||||
Args : in Mal.T_Array) return Mal.T
|
||||
is (Eval_Cb.Cb.all (Ast => Item.F_Ast,
|
||||
Env => Envs.New_Env (Outer => Item.F_Env,
|
||||
Binds => Item.F_Params,
|
||||
Exprs => Args)));
|
||||
|
||||
function Apply (Item : in Ptr;
|
||||
Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
||||
return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast,
|
||||
Env => Envs.Sub (Outer => Item.Ref.all.Env,
|
||||
Binds => Item.Ref.all.Params,
|
||||
Exprs => Args));
|
||||
end Apply;
|
||||
function Ast (Item : in Instance) return Mal.T
|
||||
is (Item.F_Ast);
|
||||
|
||||
function Ast (Item : in Ptr) return Mal.T
|
||||
is (Item.Ref.all.Ast);
|
||||
function Env (Item : in Instance) return Envs.Ptr
|
||||
is (Item.F_Env);
|
||||
|
||||
procedure Check_Allocations is
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
begin
|
||||
pragma Assert (Allocations = 0);
|
||||
end Check_Allocations;
|
||||
|
||||
function Env (Item : in Ptr) return Envs.Closure_Ptr is
|
||||
begin
|
||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
||||
return Item.Ref.all.Env;
|
||||
end Env;
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
Object.Ref.all.Refs := @ - 1;
|
||||
if 0 < Object.Ref.all.Refs then
|
||||
Object.Ref := null;
|
||||
else
|
||||
Allocations := Allocations - 1;
|
||||
Free (Object.Ref);
|
||||
Mal.Keep (Object.F_Ast);
|
||||
if Object.F_Env /= null then
|
||||
Object.F_Env.all.Keep;
|
||||
end if;
|
||||
end if;
|
||||
end Finalize;
|
||||
Mal.Keep (Object.F_Meta);
|
||||
end Keep_References;
|
||||
|
||||
function Params (Item : in Ptr) return Symbols.Symbol_Array
|
||||
is (Item.Ref.all.Params);
|
||||
function Meta (Item : in Instance) return Mal.T
|
||||
is (Item.F_Meta);
|
||||
|
||||
function Meta (Item : in Ptr) return Mal.T is
|
||||
begin
|
||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
||||
return Item.Ref.all.Meta;
|
||||
end Meta;
|
||||
|
||||
function New_Function (Params : in Sequences.Ptr;
|
||||
function New_Function (Params : in Sequences.Instance;
|
||||
Ast : in Mal.T;
|
||||
Env : in Envs.Closure_Ptr)
|
||||
Env : in Envs.Ptr)
|
||||
return Mal.T
|
||||
is
|
||||
Ref : Acc;
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref := new Rec'(Params_Last => Params.Length,
|
||||
Ast => Ast,
|
||||
Env => Env,
|
||||
Ref : constant Mal.Fn_Ptr
|
||||
:= new Instance'(Garbage_Collected.Instance with
|
||||
Last => Params.Length,
|
||||
F_Ast => Ast,
|
||||
F_Env => Env,
|
||||
others => <>);
|
||||
return R : constant Mal.T := (Kind_Fn, (AFC with Ref)) do
|
||||
for I in 1 .. Params.Length loop
|
||||
begin
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
for I in Ref.all.F_Params'Range loop
|
||||
Err.Check (Params (I).Kind = Kind_Symbol,
|
||||
"formal parameters must be symbols");
|
||||
Ref.all.Params (I) := Params (I).Symbol;
|
||||
Ref.all.F_Params (I) := Params (I).Symbol;
|
||||
end loop;
|
||||
end return;
|
||||
return (Kind_Fn, Ref);
|
||||
end New_Function;
|
||||
|
||||
function New_Macro (Item : in Ptr) return Mal.T is
|
||||
-- Avoid raising an exception until Ref is controlled.
|
||||
Ref : Acc := Item.Ref;
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Env := Envs.Null_Closure;
|
||||
-- Finalize the environment, it will not be used anymore.
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
|
||||
Params => Ref.all.Params,
|
||||
Ast => Ref.all.Ast,
|
||||
function New_Macro (Item : in Instance) return Mal.T is
|
||||
Ref : constant Mal.Fn_Ptr
|
||||
:= new Instance'(Garbage_Collected.Instance with
|
||||
Last => Item.Last,
|
||||
F_Params => Item.F_Params,
|
||||
F_Ast => Item.F_Ast,
|
||||
others => <>);
|
||||
end if;
|
||||
return (Kind_Macro, (AFC with Ref));
|
||||
begin
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return (Kind_Macro, Ref);
|
||||
end New_Macro;
|
||||
|
||||
function With_Meta (Item : in Ptr;
|
||||
function Params (Item : in Instance) return Symbols.Symbol_Array
|
||||
is (Item.F_Params);
|
||||
|
||||
function With_Meta (Item : in Instance;
|
||||
Metadata : in Mal.T) return Mal.T
|
||||
is
|
||||
-- Avoid raising an exception until Ref is controlled.
|
||||
Ref : Acc := Item.Ref;
|
||||
Ref : constant Mal.Fn_Ptr
|
||||
:= new Instance'(Garbage_Collected.Instance with
|
||||
Last => Item.Last,
|
||||
F_Params => Item.F_Params,
|
||||
F_Ast => Item.F_Ast,
|
||||
F_Env => Item.F_Env,
|
||||
F_Meta => Metadata);
|
||||
begin
|
||||
pragma Assert (Ref.all.Env /= Envs.Null_Closure);
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Metadata;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
|
||||
Params => Ref.all.Params,
|
||||
Ast => Ref.all.Ast,
|
||||
Env => Ref.all.Env,
|
||||
Meta => Metadata,
|
||||
others => <>);
|
||||
end if;
|
||||
return (Kind_Fn, (AFC with Ref));
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return (Kind_Fn, Ref);
|
||||
end With_Meta;
|
||||
|
||||
end Types.Fns;
|
||||
|
@ -1,52 +1,48 @@
|
||||
private with Ada.Finalization;
|
||||
|
||||
limited with Envs;
|
||||
limited with Types.Mal;
|
||||
limited with Types.Sequences;
|
||||
limited with Types.Symbols;
|
||||
with Envs;
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
with Types.Sequences;
|
||||
with Types.Symbols;
|
||||
|
||||
package Types.Fns is
|
||||
|
||||
type Ptr is tagged private;
|
||||
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||
-- A pointer to an user-defined function or macro.
|
||||
|
||||
function New_Function (Params : in Sequences.Ptr;
|
||||
function New_Function (Params : in Types.Sequences.Instance;
|
||||
Ast : in Mal.T;
|
||||
Env : in Envs.Closure_Ptr) return Mal.T
|
||||
Env : in Envs.Ptr) return Mal.T
|
||||
with Inline;
|
||||
-- Raise an exception if Params contains something else than symbols.
|
||||
|
||||
function New_Macro (Item : in Ptr) return Mal.T with Inline;
|
||||
function New_Macro (Item : in Instance) return Mal.T with Inline;
|
||||
|
||||
function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline;
|
||||
function Ast (Item : in Ptr) return Mal.T with Inline;
|
||||
function Params (Item : in Instance) return Symbols.Symbol_Array
|
||||
with Inline;
|
||||
function Ast (Item : in Instance) return Mal.T with Inline;
|
||||
-- Useful to print.
|
||||
|
||||
function Apply (Item : in Ptr;
|
||||
function Apply (Item : in Instance;
|
||||
Args : in Mal.T_Array) return Mal.T with Inline;
|
||||
-- Fails for macros.
|
||||
-- Returns null for macros.
|
||||
|
||||
function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline;
|
||||
-- Fails for macros. Required for TCO, instead of Apply.
|
||||
function Env (Item : in Instance) return Envs.Ptr with Inline;
|
||||
-- Returns null for macros.
|
||||
-- Required for TCO, instead of Apply.
|
||||
|
||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
||||
-- Fails for macros.
|
||||
function With_Meta (Item : in Ptr;
|
||||
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||
function With_Meta (Item : in Instance;
|
||||
Metadata : in Mal.T) return Mal.T with Inline;
|
||||
-- Fails for macros.
|
||||
|
||||
procedure Check_Allocations;
|
||||
|
||||
private
|
||||
|
||||
type Rec;
|
||||
type Acc is access Rec;
|
||||
type Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Acc := null;
|
||||
end record
|
||||
with Invariant => Ptr.Ref /= null;
|
||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
type Instance (Last : Natural) is new Garbage_Collected.Instance
|
||||
with record
|
||||
F_Ast : Mal.T;
|
||||
F_Env : Envs.Ptr;
|
||||
F_Meta : Mal.T;
|
||||
F_Params : Symbols.Symbol_Array (1 .. Last);
|
||||
end record;
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Types.Fns;
|
||||
|
@ -1,8 +1,14 @@
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
with Types.Fns;
|
||||
|
||||
package body Types.Mal is
|
||||
|
||||
use type Ada.Strings.Unbounded.Unbounded_String;
|
||||
use type Maps.Ptr;
|
||||
use type Sequences.Ptr;
|
||||
use type Maps.Instance;
|
||||
use type Sequences.Instance;
|
||||
use type Symbols.Ptr;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
@ -22,11 +28,31 @@ package body Types.Mal is
|
||||
Right.Kind = Left.Kind and then Left.S = Right.S,
|
||||
-- Here comes the part that differs from the predefined equality.
|
||||
when Kind_Sequence =>
|
||||
Right.Kind in Kind_Sequence and then Left.Sequence = Right.Sequence,
|
||||
Right.Kind in Kind_Sequence
|
||||
and then Left.Sequence.all = Right.Sequence.all,
|
||||
when Kind_Map =>
|
||||
Right.Kind = Kind_Map and then Left.Map = Right.Map,
|
||||
Right.Kind = Kind_Map and then Left.Map.all = Right.Map.all,
|
||||
-- Also, comparing functions is an interesting problem.
|
||||
when others =>
|
||||
False);
|
||||
|
||||
procedure Keep (Object : in T) is
|
||||
begin
|
||||
case Object.Kind is
|
||||
when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Key | Kind_Builtin
|
||||
| Kind_Symbol =>
|
||||
null;
|
||||
when Kind_Atom =>
|
||||
Object.Atom.all.Keep;
|
||||
when Kind_Sequence =>
|
||||
Object.Sequence.all.Keep;
|
||||
when Kind_Map =>
|
||||
Object.Map.all.Keep;
|
||||
when Kind_Builtin_With_Meta =>
|
||||
Object.Builtin_With_Meta.all.Keep;
|
||||
when Kind_Fn | Kind_Macro =>
|
||||
Object.Fn.all.Keep;
|
||||
end case;
|
||||
end Keep;
|
||||
|
||||
end Types.Mal;
|
||||
|
@ -1,10 +1,10 @@
|
||||
with Ada.Strings.Unbounded;
|
||||
|
||||
with Types.Atoms;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
with Types.Maps;
|
||||
with Types.Sequences;
|
||||
limited with Types.Atoms;
|
||||
limited with Types.Builtins;
|
||||
limited with Types.Fns;
|
||||
limited with Types.Maps;
|
||||
limited with Types.Sequences;
|
||||
with Types.Symbols;
|
||||
|
||||
package Types.Mal is
|
||||
@ -48,7 +48,13 @@ package Types.Mal is
|
||||
|
||||
type T;
|
||||
type T_Array;
|
||||
|
||||
type Atom_Ptr is access Atoms.Instance;
|
||||
type Builtin_Ptr is access function (Args : in T_Array) return T;
|
||||
type Builtin_With_Meta_Ptr is access Builtins.Instance;
|
||||
type Fn_Ptr is access Fns.Instance;
|
||||
type Map_Ptr is access Maps.Instance;
|
||||
type Sequence_Ptr is access Sequences.Instance;
|
||||
|
||||
type T (Kind : Kind_Type := Kind_Nil) is record
|
||||
case Kind is
|
||||
@ -59,21 +65,21 @@ package Types.Mal is
|
||||
when Kind_Number =>
|
||||
Number : Integer;
|
||||
when Kind_Atom =>
|
||||
Atom : Atoms.Ptr;
|
||||
Atom : Atom_Ptr;
|
||||
when Kind_Key =>
|
||||
S : Ada.Strings.Unbounded.Unbounded_String;
|
||||
when Kind_Symbol =>
|
||||
Symbol : Symbols.Ptr;
|
||||
when Kind_Sequence =>
|
||||
Sequence : Sequences.Ptr;
|
||||
Sequence : Sequence_Ptr;
|
||||
when Kind_Map =>
|
||||
Map : Maps.Ptr;
|
||||
Map : Map_Ptr;
|
||||
when Kind_Builtin =>
|
||||
Builtin : Builtin_Ptr;
|
||||
when Kind_Builtin_With_Meta =>
|
||||
Builtin_With_Meta : Builtins.Ptr;
|
||||
Builtin_With_Meta : Builtin_With_Meta_Ptr;
|
||||
when Kind_Fn | Kind_Macro =>
|
||||
Fn : Fns.Ptr;
|
||||
Fn : Fn_Ptr;
|
||||
end case;
|
||||
end record;
|
||||
|
||||
@ -83,6 +89,8 @@ package Types.Mal is
|
||||
|
||||
Nil : constant T := (Kind => Kind_Nil);
|
||||
|
||||
procedure Keep (Object : in Mal.T) with Inline;
|
||||
|
||||
type T_Array is array (Positive range <>) of T;
|
||||
|
||||
end Types.Mal;
|
||||
|
@ -1,151 +1,77 @@
|
||||
with Ada.Containers.Hashed_Maps;
|
||||
with Ada.Strings.Unbounded.Hash;
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Err;
|
||||
with Types.Sequences;
|
||||
with Types.Mal;
|
||||
|
||||
package body Types.Maps is
|
||||
|
||||
subtype AFC is Ada.Finalization.Controlled;
|
||||
use type Ada.Containers.Count_Type;
|
||||
|
||||
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type
|
||||
with Inline;
|
||||
-- This function also checks the kind of the key, and raise an
|
||||
-- error in case of problem.
|
||||
|
||||
package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
|
||||
Element_Type => Mal.T,
|
||||
Hash => Hash,
|
||||
Equivalent_Keys => Mal."=",
|
||||
"=" => Mal."=");
|
||||
use type HM.Map;
|
||||
|
||||
type Rec is limited record
|
||||
Refs : Natural := 1;
|
||||
Data : HM.Map := HM.Empty_Map;
|
||||
Meta : Mal.T := Mal.Nil;
|
||||
end record;
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
function Constructor return Mal.Map_Ptr with Inline;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
function "=" (Left, Right : in Ptr) return Boolean
|
||||
is (Left.Ref.all.Data = Right.Ref.all.Data);
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end Adjust;
|
||||
function "=" (Left, Right : in Instance) return Boolean
|
||||
is (Left.Data = Right.Data);
|
||||
|
||||
function Assoc (Args : in Mal.T_Array) return Mal.T is
|
||||
Ref : Acc;
|
||||
Ref : constant Mal.Map_Ptr := Constructor;
|
||||
begin
|
||||
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||
"parameter 1 must be a map");
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref := Args (Args'First).Map.Ref;
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Data => Ref.all.Data,
|
||||
others => <>);
|
||||
end if;
|
||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
||||
Ref.all.Data := Args (Args'First).Map.all.Data;
|
||||
for I in 1 .. Args'Length / 2 loop
|
||||
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
|
||||
New_Item => Args (Args'First + 2 * I));
|
||||
-- This call checks the kind of the key.
|
||||
end loop;
|
||||
end return;
|
||||
return (Kind_Map, Ref);
|
||||
end Assoc;
|
||||
|
||||
procedure Check_Allocations is
|
||||
begin
|
||||
pragma Assert (Allocations = 0);
|
||||
end Check_Allocations;
|
||||
|
||||
function Contains (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 2, "expected 2 parameters");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||
"parameter 1 must be a map");
|
||||
return (Kind_Boolean,
|
||||
Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)));
|
||||
Args (Args'First).Map.all.Data.Contains (Args (Args'Last)));
|
||||
end Contains;
|
||||
|
||||
function Constructor return Mal.Map_Ptr is
|
||||
Ref : constant Mal.Map_Ptr := new Instance;
|
||||
begin
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return Ref;
|
||||
end Constructor;
|
||||
|
||||
function Dissoc (Args : in Mal.T_Array) return Mal.T is
|
||||
Ref : Acc;
|
||||
Ref : constant Mal.Map_Ptr := Constructor;
|
||||
begin
|
||||
Err.Check (0 < Args'Length, "expected at least 1 parameter");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||
"parameter 1 must be a map");
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref := Args (Args'First).Map.Ref;
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Data => Ref.all.Data,
|
||||
others => <>);
|
||||
end if;
|
||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
||||
Ref.all.Data := Args (Args'First).Map.all.Data;
|
||||
for I in Args'First + 1 .. Args'Last loop
|
||||
Ref.all.Data.Exclude (Args (I));
|
||||
-- This call checks the kind of the key.
|
||||
end loop;
|
||||
end return;
|
||||
return (Kind_Map, Ref);
|
||||
end Dissoc;
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
Object.Ref.all.Refs := @ - 1;
|
||||
if 0 < Object.Ref.all.Refs then
|
||||
Object.Ref := null;
|
||||
else
|
||||
Allocations := Allocations - 1;
|
||||
Free (Object.Ref);
|
||||
end if;
|
||||
end if;
|
||||
end Finalize;
|
||||
|
||||
function Generic_Eval (Container : in Ptr;
|
||||
Env : in Env_Type)
|
||||
return Mal.T
|
||||
function Generic_Eval (Container : in Instance;
|
||||
Env : in Env_Type) return Mal.T
|
||||
is
|
||||
-- Copy the whole hash in order to avoid recomputing the hash
|
||||
-- for each key, even if it implies unneeded calls to adjust
|
||||
-- and finalize for Mal_Type values.
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : Acc := Container.Ref;
|
||||
Ref : constant Mal.Map_Ptr := Constructor;
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Data => Ref.all.Data,
|
||||
others => <>);
|
||||
end if;
|
||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
||||
Ref.Data := Container.Data;
|
||||
for Position in Ref.all.Data.Iterate loop
|
||||
Ref.all.Data.Replace_Element (Position,
|
||||
Eval (HM.Element (Position), Env));
|
||||
-- This call may raise exceptions.
|
||||
end loop;
|
||||
end return;
|
||||
return Mal.T'(Kind_Map, Ref);
|
||||
end Generic_Eval;
|
||||
|
||||
function Get (Args : in Mal.T_Array) return Mal.T is
|
||||
@ -158,8 +84,7 @@ package body Types.Maps is
|
||||
"key must be a keyword or string");
|
||||
return Mal.Nil;
|
||||
when Kind_Map =>
|
||||
Position
|
||||
:= Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last));
|
||||
Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last));
|
||||
-- This call checks the kind of the key.
|
||||
if HM.Has_Element (Position) then
|
||||
return HM.Element (Position);
|
||||
@ -179,86 +104,83 @@ package body Types.Maps is
|
||||
|
||||
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
|
||||
Binds : constant Natural := Args'Length / 2;
|
||||
Ref : Acc;
|
||||
Ref : Mal.Map_Ptr;
|
||||
begin
|
||||
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
|
||||
Allocations := Allocations + 1;
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref := new Rec;
|
||||
Ref := Constructor;
|
||||
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
|
||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
||||
for I in 0 .. Binds - 1 loop
|
||||
Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
|
||||
New_Item => Args (Args'First + 2 * I + 1));
|
||||
-- This call checks the kind of the key.
|
||||
end loop;
|
||||
end return;
|
||||
return (Kind_Map, Ref);
|
||||
end Hash_Map;
|
||||
|
||||
procedure Iterate (Container : in Ptr) is
|
||||
procedure Iterate (Container : in Instance) is
|
||||
begin
|
||||
for Position in Container.Ref.all.Data.Iterate loop
|
||||
for Position in Container.Data.Iterate loop
|
||||
Process (HM.Key (Position), HM.Element (Position));
|
||||
end loop;
|
||||
end Iterate;
|
||||
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
begin
|
||||
for Position in Object.Data.Iterate loop
|
||||
Mal.Keep (HM.Key (Position));
|
||||
Mal.Keep (HM.Element (Position));
|
||||
end loop;
|
||||
Mal.Keep (Object.F_Meta);
|
||||
end Keep_References;
|
||||
|
||||
function Keys (Args : in Mal.T_Array) return Mal.T is
|
||||
A1 : Mal.Map_Ptr;
|
||||
R : Mal.Sequence_Ptr;
|
||||
I : Positive := 1;
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||
"parameter 1 must be a map");
|
||||
declare
|
||||
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
|
||||
R : Mal.T_Array (1 .. Natural (A1.Length));
|
||||
I : Positive := 1;
|
||||
begin
|
||||
for Position in A1.Iterate loop
|
||||
R (I) := HM.Key (Position);
|
||||
A1 := Args (Args'First).Map;
|
||||
R := Sequences.Constructor (A1.all.Length);
|
||||
for Position in A1.all.Data.Iterate loop
|
||||
R.all.Replace_Element (I, HM.Key (Position));
|
||||
I := I + 1;
|
||||
end loop;
|
||||
return Sequences.List (R);
|
||||
end;
|
||||
return (Kind_List, R);
|
||||
end Keys;
|
||||
|
||||
function Meta (Container : in Ptr) return Mal.T
|
||||
is (Container.Ref.all.Meta);
|
||||
function Length (Container : in Instance) return Natural
|
||||
is (Natural (Container.Data.Length));
|
||||
|
||||
function Meta (Container : in Instance) return Mal.T
|
||||
is (Container.F_Meta);
|
||||
|
||||
function Vals (Args : in Mal.T_Array) return Mal.T is
|
||||
A1 : Mal.Map_Ptr;
|
||||
R : Mal.Sequence_Ptr;
|
||||
I : Positive := 1;
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||
"parameter 1 must be a map");
|
||||
declare
|
||||
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
|
||||
R : Mal.T_Array (1 .. Natural (A1.Length));
|
||||
I : Positive := 1;
|
||||
begin
|
||||
for Element of A1 loop
|
||||
R (I) := Element;
|
||||
A1 := Args (Args'First).Map;
|
||||
R := Sequences.Constructor (A1.all.Length);
|
||||
for Element of A1.all.Data loop
|
||||
R.all.Replace_Element (I, Element);
|
||||
I := I + 1;
|
||||
end loop;
|
||||
return Sequences.List (R);
|
||||
end;
|
||||
return (Kind_List, R);
|
||||
end Vals;
|
||||
|
||||
function With_Meta (Data : in Ptr;
|
||||
Metadata : in Mal.T)
|
||||
return Mal.T
|
||||
function With_Meta (Data : in Instance;
|
||||
Metadata : in Mal.T) return Mal.T
|
||||
is
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : Acc := Data.Ref;
|
||||
Ref : constant Mal.Map_Ptr := Constructor;
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Metadata;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Data => Ref.all.Data,
|
||||
Meta => Metadata,
|
||||
others => <>);
|
||||
end if;
|
||||
return (Kind_Map, (AFC with Ref));
|
||||
Ref.all.Data := Data.Data;
|
||||
Ref.all.F_Meta := Metadata;
|
||||
return (Kind_Map, Ref);
|
||||
end With_Meta;
|
||||
|
||||
end Types.Maps;
|
||||
|
@ -1,10 +1,11 @@
|
||||
private with Ada.Finalization;
|
||||
private with Ada.Containers.Hashed_Maps;
|
||||
|
||||
limited with Types.Mal;
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
|
||||
package Types.Maps is
|
||||
|
||||
type Ptr is tagged private;
|
||||
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||
|
||||
-- Built-in functions.
|
||||
function Assoc (Args : in Mal.T_Array) return Mal.T;
|
||||
@ -15,17 +16,19 @@ package Types.Maps is
|
||||
function Keys (Args : in Mal.T_Array) return Mal.T;
|
||||
function Vals (Args : in Mal.T_Array) return Mal.T;
|
||||
|
||||
function "=" (Left, Right : in Instance) return Boolean with Inline;
|
||||
|
||||
-- A generic is better than an access to function because of
|
||||
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
|
||||
|
||||
-- Used to evaluate each element of a map.
|
||||
-- Eval is generic because units cannot depend on each other.
|
||||
|
||||
generic
|
||||
type Env_Type (<>) is limited private;
|
||||
with function Eval (Ast : in Mal.T;
|
||||
Env : in Env_Type)
|
||||
return Mal.T;
|
||||
function Generic_Eval (Container : in Ptr;
|
||||
function Generic_Eval (Container : in Instance;
|
||||
Env : in Env_Type)
|
||||
return Mal.T;
|
||||
|
||||
@ -33,28 +36,32 @@ package Types.Maps is
|
||||
generic
|
||||
with procedure Process (Key : in Mal.T;
|
||||
Element : in Mal.T);
|
||||
procedure Iterate (Container : in Ptr);
|
||||
procedure Iterate (Container : in Instance);
|
||||
|
||||
function Meta (Container : in Ptr) return Mal.T with Inline;
|
||||
function Length (Container : in Instance) return Natural with Inline;
|
||||
|
||||
function With_Meta (Data : in Ptr;
|
||||
function Meta (Container : in Instance) return Mal.T with Inline;
|
||||
function With_Meta (Data : in Instance;
|
||||
Metadata : in Mal.T)
|
||||
return Mal.T;
|
||||
|
||||
-- Debug
|
||||
procedure Check_Allocations;
|
||||
|
||||
private
|
||||
|
||||
type Rec;
|
||||
type Acc is access Rec;
|
||||
type Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Acc := null;
|
||||
end record
|
||||
with Invariant => Ptr.Ref /= null;
|
||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
overriding function "=" (Left, Right : in Ptr) return Boolean with Inline;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline;
|
||||
-- This function also checks the kind of the key, and raise an
|
||||
-- error in case of problem.
|
||||
|
||||
package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
|
||||
Element_Type => Mal.T,
|
||||
Hash => Hash,
|
||||
Equivalent_Keys => Mal."=",
|
||||
"=" => Mal."=");
|
||||
use type HM.Map;
|
||||
|
||||
type Instance is new Garbage_Collected.Instance with record
|
||||
Data : HM.Map;
|
||||
F_Meta : Mal.T;
|
||||
end record;
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Types.Maps;
|
||||
|
@ -1,68 +1,44 @@
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
with Err;
|
||||
with Types.Mal;
|
||||
with Types.Builtins;
|
||||
with Types.Fns;
|
||||
|
||||
package body Types.Sequences is
|
||||
|
||||
subtype AFC is Ada.Finalization.Controlled;
|
||||
use type Mal.T_Array;
|
||||
|
||||
type Rec (Last : Natural) is limited record
|
||||
Refs : Natural := 1;
|
||||
Meta : Mal.T := Mal.Nil;
|
||||
Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil);
|
||||
end record;
|
||||
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
function "=" (Left, Right : in Ptr) return Boolean is
|
||||
function "=" (Left, Right : in Instance) return Boolean is
|
||||
-- Should become Left.Ref.all.Data = Right.Ref.all.Data when
|
||||
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
|
||||
use type Mal.T;
|
||||
L : Rec renames Left.Ref.all;
|
||||
R : Rec renames Right.Ref.all;
|
||||
begin
|
||||
return L.Last = R.Last
|
||||
and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I));
|
||||
return Left.Last = Right.Last
|
||||
and then
|
||||
(for all I in 1 .. Left.Last => Left.Data (I) = Right.Data (I));
|
||||
end "=";
|
||||
|
||||
function "&" (Left : in Mal.T_Array;
|
||||
Right : in Ptr) return Mal.T_Array
|
||||
is (Left & Right.Ref.all.Data);
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
end Adjust;
|
||||
|
||||
procedure Check_Allocations is
|
||||
begin
|
||||
pragma Assert (Allocations = 0);
|
||||
end Check_Allocations;
|
||||
Right : in Instance) return Mal.T_Array
|
||||
is (Left & Right.Data);
|
||||
|
||||
function Concat (Args : in Mal.T_Array) return Mal.T is
|
||||
Sum : Natural := 0;
|
||||
First : Positive := 1;
|
||||
Last : Natural;
|
||||
Ref : Acc;
|
||||
Ref : Mal.Sequence_Ptr;
|
||||
begin
|
||||
for Arg of Args loop
|
||||
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences");
|
||||
Sum := Sum + Arg.Sequence.Ref.all.Data'Length;
|
||||
Sum := Sum + Arg.Sequence.all.Data'Length;
|
||||
end loop;
|
||||
Allocations := Allocations + 1;
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref := new Rec (Sum);
|
||||
Ref := Constructor (Sum);
|
||||
for Arg of Args loop
|
||||
Last := First - 1 + Arg.Sequence.Ref.all.Data'Length;
|
||||
Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data;
|
||||
Last := First - 1 + Arg.Sequence.all.Data'Length;
|
||||
Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
|
||||
First := Last + 1;
|
||||
end loop;
|
||||
return (Kind_List, (AFC with Ref));
|
||||
return (Kind_List, Ref);
|
||||
end Concat;
|
||||
|
||||
function Conj (Args : in Mal.T_Array) return Mal.T is
|
||||
@ -71,21 +47,20 @@ package body Types.Sequences is
|
||||
case Args (Args'First).Kind is
|
||||
when Kind_Sequence =>
|
||||
declare
|
||||
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
||||
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||
Last : constant Natural := Args'Length - 1 + Data'Length;
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : constant Acc := new Rec (Last);
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (Last);
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
if Args (Args'First).Kind = Kind_List then
|
||||
for I in 1 .. Args'Length - 1 loop
|
||||
Ref.all.Data (I) := Args (Args'Last - I + 1);
|
||||
end loop;
|
||||
Ref.all.Data (Args'Length .. Last) := Data;
|
||||
return (Kind_List, (AFC with Ref));
|
||||
return (Kind_List, Ref);
|
||||
else
|
||||
Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
|
||||
return (Kind_Vector, (AFC with Ref));
|
||||
return (Kind_Vector, Ref);
|
||||
end if;
|
||||
end;
|
||||
when others =>
|
||||
@ -100,15 +75,21 @@ package body Types.Sequences is
|
||||
"parameter 2 must be a sequence");
|
||||
declare
|
||||
Head : Mal.T renames Args (Args'First);
|
||||
Tail : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
|
||||
Tail : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (1 + Tail'Length);
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length,
|
||||
Data => Head & Tail,
|
||||
others => <>)));
|
||||
Ref.all.Data := Head & Tail;
|
||||
return (Kind_List, Ref);
|
||||
end;
|
||||
end Cons;
|
||||
|
||||
function Constructor (Length : in Natural) return Mal.Sequence_Ptr is
|
||||
Ref : constant Mal.Sequence_Ptr := new Instance (Length);
|
||||
begin
|
||||
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||
return Ref;
|
||||
end Constructor;
|
||||
|
||||
function Count (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
@ -116,28 +97,15 @@ package body Types.Sequences is
|
||||
when Kind_Nil =>
|
||||
return (Kind_Number, 0);
|
||||
when Kind_Sequence =>
|
||||
return (Kind_Number, Args (Args'First).Sequence.Ref.all.Data'Length);
|
||||
return (Kind_Number, Args (Args'First).Sequence.all.Data'Length);
|
||||
when others =>
|
||||
Err.Raise_With ("parameter must be nil or a sequence");
|
||||
end case;
|
||||
end Count;
|
||||
|
||||
function Element (Container : in Ptr;
|
||||
function Element (Container : in Instance;
|
||||
Index : in Positive) return Mal.T
|
||||
is (Container.Ref.all.Data (Index));
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
Object.Ref.all.Refs := @ - 1;
|
||||
if 0 < Object.Ref.all.Refs then
|
||||
Object.Ref := null;
|
||||
else
|
||||
Allocations := Allocations - 1;
|
||||
Free (Object.Ref);
|
||||
end if;
|
||||
end if;
|
||||
end Finalize;
|
||||
is (Container.Data (Index));
|
||||
|
||||
function First (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
@ -147,7 +115,7 @@ package body Types.Sequences is
|
||||
return Mal.Nil;
|
||||
when Kind_Sequence =>
|
||||
declare
|
||||
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
||||
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||
begin
|
||||
if Data'Length = 0 then
|
||||
return Mal.Nil;
|
||||
@ -160,48 +128,30 @@ package body Types.Sequences is
|
||||
end case;
|
||||
end First;
|
||||
|
||||
function Generic_Eval (Container : in Ptr;
|
||||
Env : in Env_Type)
|
||||
return Ptr
|
||||
is
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : Acc := Container.Ref;
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec (Ref.all.Last);
|
||||
end if;
|
||||
return R : constant Ptr := (AFC with Ref) do
|
||||
for I in Container.Ref.all.Data'Range loop
|
||||
Ref.all.Data (I) := Eval (Container.Ref.all.Data (I), Env);
|
||||
-- This call may raise exceptions.
|
||||
-- The target may be the source.
|
||||
end loop;
|
||||
end return;
|
||||
end Generic_Eval;
|
||||
|
||||
function Is_Empty (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
Err.Check (Args (Args'First).Kind in Kind_Sequence,
|
||||
"parameter must be a sequence");
|
||||
return (Kind_Boolean,
|
||||
Args (Args'First).Sequence.Ref.all.Data'Length = 0);
|
||||
return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
|
||||
end Is_Empty;
|
||||
|
||||
function Length (Source : in Ptr) return Natural
|
||||
is (Source.Ref.all.Data'Length);
|
||||
procedure Keep_References (Object : in out Instance) is
|
||||
begin
|
||||
Mal.Keep (Object.F_Meta);
|
||||
for M of Object.Data loop
|
||||
Mal.Keep (M);
|
||||
end loop;
|
||||
end Keep_References;
|
||||
|
||||
function Length (Source : in Instance) return Natural
|
||||
is (Source.Data'Length);
|
||||
|
||||
function List (Args : in Mal.T_Array) return Mal.T is
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
return (Kind_List, (AFC with new Rec'(Data => Args,
|
||||
Last => Args'Length,
|
||||
others => <>)));
|
||||
Ref.all.Data := Args;
|
||||
return (Kind_List, Ref);
|
||||
end List;
|
||||
|
||||
function Map (Args : in Mal.T_Array) return Mal.T is
|
||||
@ -211,44 +161,32 @@ package body Types.Sequences is
|
||||
"parameter 2 must be a sequence");
|
||||
declare
|
||||
F : Mal.T renames Args (Args'First);
|
||||
Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : Acc := Args (Args'Last).Sequence.Ref;
|
||||
Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length);
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Mal.Nil;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec (Ref.all.Last);
|
||||
end if;
|
||||
return R : constant Mal.T := (Kind_List, (AFC with Ref)) do
|
||||
case F.Kind is
|
||||
when Kind_Builtin =>
|
||||
for I in Src'Range loop
|
||||
Ref.all.Data (I) := F.Builtin.all (Src (I .. I));
|
||||
-- This call may raise exceptions.
|
||||
-- The target may be the same storage than the source.
|
||||
end loop;
|
||||
when Kind_Builtin_With_Meta =>
|
||||
for I in Src'Range loop
|
||||
Ref.all.Data (I)
|
||||
:= F.Builtin_With_Meta.Builtin.all (Src (I .. I));
|
||||
:= F.Builtin_With_Meta.all.Builtin.all (Src (I .. I));
|
||||
end loop;
|
||||
when Kind_Fn =>
|
||||
for I in Src'Range loop
|
||||
Ref.all.Data (I) := F.Fn.Apply (Src (I .. I));
|
||||
Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I));
|
||||
end loop;
|
||||
when others =>
|
||||
Err.Raise_With ("parameter 1 must be a function");
|
||||
end case;
|
||||
end return;
|
||||
return (Kind_List, Ref);
|
||||
end;
|
||||
end Map;
|
||||
|
||||
function Meta (Item : in Ptr) return Mal.T
|
||||
is (Item.Ref.all.Meta);
|
||||
function Meta (Item : in Instance) return Mal.T
|
||||
is (Item.F_Meta);
|
||||
|
||||
function Nth (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
@ -258,7 +196,7 @@ package body Types.Sequences is
|
||||
Err.Check (Args (Args'Last).Kind = Kind_Number,
|
||||
"parameter 2 must be a number");
|
||||
declare
|
||||
L : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
||||
L : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||
I : constant Integer := Args (Args'Last).Number + 1;
|
||||
begin
|
||||
Err.Check (I in L'Range, "index out of bounds");
|
||||
@ -266,70 +204,62 @@ package body Types.Sequences is
|
||||
end;
|
||||
end Nth;
|
||||
|
||||
procedure Replace_Element (Container : in out Instance;
|
||||
Index : in Positive;
|
||||
New_Item : in Mal.T)
|
||||
is
|
||||
begin
|
||||
Container.Data (Index) := New_Item;
|
||||
end Replace_Element;
|
||||
|
||||
function Rest (Args : in Mal.T_Array) return Mal.T is
|
||||
begin
|
||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||
declare
|
||||
A1 : Mal.T renames Args (Args'First);
|
||||
Ref : Acc;
|
||||
Ref : Mal.Sequence_Ptr;
|
||||
begin
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
case A1.Kind is
|
||||
when Kind_Nil =>
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec (0);
|
||||
Ref := Constructor (0);
|
||||
when Kind_Sequence =>
|
||||
Allocations := Allocations + 1;
|
||||
if A1.Sequence.Ref.all.Last = 0 then
|
||||
Ref := new Rec (0);
|
||||
if A1.Sequence.all.Last = 0 then
|
||||
Ref := Constructor (0);
|
||||
else
|
||||
Ref := new Rec'
|
||||
(Last => A1.Sequence.Ref.all.Last - 1,
|
||||
Data => A1.Sequence.Ref.all.Data
|
||||
(2 .. A1.Sequence.Ref.all.Data'Last),
|
||||
others => <>);
|
||||
Ref := Constructor (A1.Sequence.all.Last - 1);
|
||||
Ref.all.Data
|
||||
:= A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last);
|
||||
end if;
|
||||
when others =>
|
||||
Err.Raise_With ("parameter must be nil or a sequence");
|
||||
end case;
|
||||
return (Kind_List, (AFC with Ref));
|
||||
return (Kind_List, Ref);
|
||||
end;
|
||||
end Rest;
|
||||
|
||||
function Tail (Source : in Ptr;
|
||||
function Tail (Source : in Instance;
|
||||
Count : in Natural) return Mal.T_Array is
|
||||
Data : Mal.T_Array renames Source.Ref.all.Data;
|
||||
Data : Mal.T_Array renames Source.Data;
|
||||
begin
|
||||
return Data (Data'Last - Count + 1 .. Data'Last);
|
||||
end Tail;
|
||||
|
||||
function Vector (Args : in Mal.T_Array) return Mal.T is
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
|
||||
begin
|
||||
Allocations := Allocations + 1;
|
||||
return (Kind_Vector, (AFC with new Rec'(Data => Args,
|
||||
Last => Args'Length,
|
||||
others => <>)));
|
||||
Ref.all.Data := Args;
|
||||
return (Kind_Vector, Ref);
|
||||
end Vector;
|
||||
|
||||
function With_Meta (Data : in Ptr;
|
||||
Metadata : in Mal.T) return Ptr
|
||||
function With_Meta (Data : in Instance;
|
||||
Metadata : in Mal.T) return Mal.Sequence_Ptr
|
||||
is
|
||||
-- Avoid exceptions until Ref is controlled.
|
||||
Ref : Acc := Data.Ref;
|
||||
|
||||
Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last);
|
||||
begin
|
||||
pragma Assert (0 < Ref.all.Refs);
|
||||
if Ref.all.Refs = 1 then
|
||||
Ref.all.Refs := 2;
|
||||
Ref.all.Meta := Metadata;
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Last => Ref.all.Last,
|
||||
Data => Ref.all.Data,
|
||||
Meta => Metadata,
|
||||
others => <>);
|
||||
end if;
|
||||
return (AFC with Ref);
|
||||
Ref.all.Data := Data.Data;
|
||||
Ref.all.F_Meta := Metadata;
|
||||
return Ref;
|
||||
end With_Meta;
|
||||
|
||||
end Types.Sequences;
|
||||
|
@ -1,10 +1,9 @@
|
||||
private with Ada.Finalization;
|
||||
|
||||
limited with Types.Mal;
|
||||
with Garbage_Collected;
|
||||
with Types.Mal;
|
||||
|
||||
package Types.Sequences is
|
||||
|
||||
type Ptr is tagged private
|
||||
type Instance (<>) is new Garbage_Collected.Instance with private
|
||||
with Constant_Indexing => Element;
|
||||
|
||||
-- Built-in functions.
|
||||
@ -20,59 +19,41 @@ package Types.Sequences is
|
||||
function Rest (Args : in Mal.T_Array) return Mal.T;
|
||||
function Vector (Args : in Mal.T_Array) return Mal.T;
|
||||
|
||||
function Length (Source : in Ptr) return Natural with Inline;
|
||||
function "=" (Left, Right : in Instance) return Boolean with Inline;
|
||||
|
||||
function Element (Container : in Ptr;
|
||||
function Length (Source : in Instance) return Natural with Inline;
|
||||
|
||||
function Element (Container : in Instance;
|
||||
Index : in Positive) return Mal.T
|
||||
with Inline, Pre => Index <= Length (Container);
|
||||
|
||||
function "&" (Left : in Mal.T_Array;
|
||||
Right : in Ptr) return Mal.T_Array;
|
||||
Right : in Instance) return Mal.T_Array with Inline;
|
||||
-- Used to implement Core.Apply.
|
||||
|
||||
-- Used to evaluate each element of a list/vector.
|
||||
-- Eval is generic because units cannot depend on each other.
|
||||
generic
|
||||
type Env_Type (<>) is limited private;
|
||||
with function Eval (Ast : in Mal.T;
|
||||
Env : in Env_Type)
|
||||
return Mal.T;
|
||||
function Generic_Eval (Container : in Ptr;
|
||||
Env : in Env_Type)
|
||||
return Ptr;
|
||||
function Constructor (Length : in Natural) return Mal.Sequence_Ptr
|
||||
with Inline;
|
||||
procedure Replace_Element (Container : in out Instance;
|
||||
Index : in Positive;
|
||||
New_Item : in Mal.T)
|
||||
with Inline, Pre => Index <= Length (Container);
|
||||
|
||||
-- Used in macro implementation.
|
||||
function Tail (Source : in Ptr;
|
||||
function Tail (Source : in Instance;
|
||||
Count : in Natural) return Mal.T_Array
|
||||
with Inline, Pre => Count <= Length (Source);
|
||||
|
||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
||||
function With_Meta (Data : in Ptr;
|
||||
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||
function With_Meta (Data : in Instance;
|
||||
Metadata : in Mal.T)
|
||||
return Ptr;
|
||||
|
||||
-- Debug.
|
||||
procedure Check_Allocations;
|
||||
return Mal.Sequence_Ptr;
|
||||
|
||||
private
|
||||
|
||||
-- It is tempting to use null to represent an empty list, but the
|
||||
-- performance is not improved much, and the code is more complex.
|
||||
-- In addition, the empty list may want to carry metadata.
|
||||
|
||||
-- Similarly, always providing a default value like a pointer to a
|
||||
-- static empty list would not gain much, and probably hide some
|
||||
-- bugs.
|
||||
|
||||
type Rec;
|
||||
type Acc is access Rec;
|
||||
type Ptr is new Ada.Finalization.Controlled with record
|
||||
Ref : Acc := null;
|
||||
end record
|
||||
with Invariant => Ptr.Ref /= null;
|
||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
||||
overriding function "=" (Left, Right : in Ptr) return Boolean;
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
type Instance (Last : Natural) is new Garbage_Collected.Instance with record
|
||||
F_Meta : Mal.T;
|
||||
Data : Mal.T_Array (1 .. Last);
|
||||
end record;
|
||||
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||
|
||||
end Types.Sequences;
|
||||
|
@ -1,42 +1,31 @@
|
||||
with Ada.Containers.Ordered_Sets;
|
||||
with Ada.Containers.Hashed_Sets;
|
||||
with Ada.Strings.Hash;
|
||||
with Ada.Unchecked_Deallocation;
|
||||
|
||||
package body Types.Symbols is
|
||||
|
||||
-- For the global dictionnary of symbols, an ordered set seems
|
||||
-- better than a hash map.
|
||||
|
||||
type Rec (Last : Positive) is limited record
|
||||
Refs : Natural;
|
||||
Hash : Ada.Containers.Hash_Type;
|
||||
Data : String (1 .. Last);
|
||||
end record;
|
||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||
Allocations : Natural := 0;
|
||||
|
||||
function "<" (Left, Right : in Acc) return Boolean with Inline;
|
||||
function Eq (Left, Right : in Acc) return Boolean with Inline;
|
||||
-- It would be unwise to name this function "=" and override the
|
||||
-- predefined equality for Acc.
|
||||
-- We only search by key and insert new elements, so this should
|
||||
-- always return False.
|
||||
package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc,
|
||||
"<" => "<",
|
||||
"=" => Eq);
|
||||
|
||||
function Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline;
|
||||
package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc,
|
||||
Hash => Hash,
|
||||
Equivalent_Elements => "=",
|
||||
"=" => "=");
|
||||
function Key (Item : in Acc) return String with Inline;
|
||||
package Keys is new Sets.Generic_Keys (Key_Type => String,
|
||||
Key => Key,
|
||||
"<" => Standard."<");
|
||||
Hash => Ada.Strings.Hash,
|
||||
Equivalent_Keys => "=");
|
||||
|
||||
Dict : Sets.Set;
|
||||
|
||||
----------------------------------------------------------------------
|
||||
|
||||
function "<" (Left, Right : in Acc) return Boolean
|
||||
is (Left.all.Data < Right.all.Data);
|
||||
|
||||
procedure Adjust (Object : in out Ptr) is
|
||||
begin
|
||||
Object.Ref.all.Refs := @ + 1;
|
||||
@ -59,7 +48,6 @@ package body Types.Symbols is
|
||||
else
|
||||
Allocations := Allocations + 1;
|
||||
Ref := new Rec'(Data => Source,
|
||||
Hash => Ada.Strings.Hash (Source),
|
||||
Last => Source'Length,
|
||||
Refs => 1);
|
||||
Dict.Insert (Ref);
|
||||
@ -67,13 +55,6 @@ package body Types.Symbols is
|
||||
return (Ada.Finalization.Controlled with Ref);
|
||||
end Constructor;
|
||||
|
||||
function Eq (Left, Right : in Acc) return Boolean is
|
||||
begin
|
||||
pragma Assert (Left /= Right);
|
||||
pragma Assert (Left.all.Data /= Right.all.Data);
|
||||
return False;
|
||||
end Eq;
|
||||
|
||||
procedure Finalize (Object : in out Ptr) is
|
||||
begin
|
||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||
@ -88,8 +69,11 @@ package body Types.Symbols is
|
||||
end if;
|
||||
end Finalize;
|
||||
|
||||
function Hash (Item : in Acc) return Ada.Containers.Hash_Type
|
||||
is (Ada.Strings.Hash (Item.all.Data));
|
||||
|
||||
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
|
||||
is (Item.Ref.all.Hash);
|
||||
is (Ada.Strings.Hash (Item.Ref.all.Data));
|
||||
|
||||
function Key (Item : in Acc) return String
|
||||
is (Item.all.Data);
|
||||
|
@ -3,6 +3,10 @@ private with Ada.Finalization;
|
||||
|
||||
package Types.Symbols with Preelaborate is
|
||||
|
||||
-- Like keys, symbols are immutable final nodes in the internal
|
||||
-- data structures. For them, reference counting is probably more
|
||||
-- efficient than garbage collecting.
|
||||
|
||||
type Ptr is tagged private;
|
||||
|
||||
function Constructor (Source : in String) return Ptr with Inline;
|
||||
@ -13,12 +17,18 @@ package Types.Symbols with Preelaborate is
|
||||
-- probability to end up as keys in an environment.
|
||||
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline;
|
||||
|
||||
-- Equality compares the contents.
|
||||
-- The implementation ensures that a given content is only
|
||||
-- allocated once, so equality of pointers gives the same result
|
||||
-- than comparing the strings.
|
||||
|
||||
type Symbol_Array is array (Positive range <>) of Symbols.Ptr;
|
||||
type Symbol_Array is array (Positive range <>) of Ptr;
|
||||
Empty_Array : constant Symbol_Array;
|
||||
-- It is convenient to define this here because the default value
|
||||
-- for Ptr is invalid.
|
||||
|
||||
-- Debug.
|
||||
procedure Check_Allocations;
|
||||
procedure Check_Allocations with Inline;
|
||||
-- Does nothing if assertions are disabled.
|
||||
|
||||
private
|
||||
|
||||
@ -49,4 +59,9 @@ private
|
||||
-- Predefined equality is fine.
|
||||
pragma Finalize_Storage_Only (Ptr);
|
||||
|
||||
Empty_Array : constant Symbol_Array
|
||||
:= (1 .. 0 => (Ada.Finalization.Controlled with null));
|
||||
-- This will not trigger the invariant check because no element is
|
||||
-- ever actually instantiated.
|
||||
|
||||
end Types.Symbols;
|
||||
|
Loading…
Reference in New Issue
Block a user