mirror of
https://github.com/kanaka/mal.git
synced 2024-09-21 02:27:10 +03:00
ada.2: fix memory leaks with garbage collection. Various simplifications.
Cyclic references were never deallocated by reference conuting. Symbols cannot create cyclic structures and are less frequent (one allocation per symbol), keep reference counting for them. This slightly improves performances even though many previous optimizations are removed (environment stack, reuse of memory). Step caching hash of symbols. This does not seem to improve performances. Hashing them instead of ordering them does. Define Repl in the step file instead of globally. Move the eval built-in function from core into the step file. When possible, pass Ada records instead of explicit pointers. In the reader, construct more objects directly as described in the MAL process, reserve the buffer for sequences and maps In eval, iterate on vectors without delegation. The increased complexity was not improving performances. Keep demonstrating Ada type-safe genericity for maps, where iterating outside Types.Maps would be less easy and/or efficient. In quasiquote_list, concatenate in one buffer instead of allocating a list for each element. The buffer may be reallocated behind the curtain, but not once per element anymore. In environments, illustrate tail call optimization when recursion is more readable than a loop.
This commit is contained in:
parent
6d9e1684de
commit
5a07bb5331
@ -37,6 +37,7 @@ TYPES := \
|
|||||||
envs.ads envs.adb \
|
envs.ads envs.adb \
|
||||||
err.ads err.adb \
|
err.ads err.adb \
|
||||||
eval_cb.ads \
|
eval_cb.ads \
|
||||||
|
garbage_collected.ads garbage_collected.adb \
|
||||||
printer.ads printer.adb \
|
printer.ads printer.adb \
|
||||||
reader.ads reader.adb \
|
reader.ads reader.adb \
|
||||||
readline.ads \
|
readline.ads \
|
||||||
|
37
ada.2/README
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
|
* Lists are implemented as C-style arrays, and most of them can be
|
||||||
allocated on the stack.
|
allocated on the stack.
|
||||||
|
|
||||||
Once each component has an explicit interface, various optimizations
|
Another difference is that a minimal form of garbage collecting is
|
||||||
have been added: unique allocation of symbols, stack-style allocation
|
implemented, removing objects not referenced from the main
|
||||||
of environments in the current execution path, reuse of allocated
|
environment. Reference counting is convenient for symbols or strings,
|
||||||
memory when the reference count reaches 1...
|
but never deallocates cyclic structures. The implementation collects
|
||||||
|
garbage after each Read-Eval-Print cycle. It would be much more
|
||||||
|
difficult to collect garbage inside scripts. If this is ever done, it
|
||||||
|
would be better to reimplement load-file in Ada and run a cycle after
|
||||||
|
each root evaluation.
|
||||||
|
|
||||||
The eventual performances compete with C-style languages, allthough
|
The eventual performances compete with C-style languages, allthough
|
||||||
all user input is checked (implicit language-defined checks like array
|
all user input is checked (implicit language-defined checks like array
|
||||||
bounds and discriminant consistency are only enabled during tests).
|
bounds and discriminant consistency are only enabled during tests).
|
||||||
|
|
||||||
There are also similarities with the first implementation. For
|
|
||||||
example, both rely on user-defined finalization to count references in
|
|
||||||
recursive structures instead of a posteriori garbage collection.
|
|
||||||
|
|
||||||
Notes for contributors that do not fit in a specific package.
|
Notes for contributors that do not fit in a specific package.
|
||||||
--
|
--
|
||||||
|
|
||||||
@ -35,24 +35,29 @@ Notes for contributors that do not fit in a specific package.
|
|||||||
ensuring a valid value during elaboration.
|
ensuring a valid value during elaboration.
|
||||||
Note that generic packages cannot export access values.
|
Note that generic packages cannot export access values.
|
||||||
|
|
||||||
* All wrapped pointers are non null, new variables must be assigned
|
* Symbol pointers are non null, new variables must be assigned
|
||||||
immediately. This is usually enforced by a hidden discriminant, but
|
immediately. This is usually enforced by a hidden discriminant, but
|
||||||
here we want the type to become a field inside Types.Mal.T. So the
|
here we want the type to become a field inside Types.Mal.T. So the
|
||||||
check happens at run time with a private invariant.
|
check happens at run time with a private invariant.
|
||||||
|
|
||||||
* The finalize procedure may be called twice, so it does nothing when
|
The finalize procedure may be called twice, so it does nothing when
|
||||||
the reference count is zero, meaning that we are reaching Finalize
|
the reference count is zero, meaning that we are reaching Finalize
|
||||||
recursively.
|
recursively.
|
||||||
|
|
||||||
* In implementations, a consistent object (that will be deallocated
|
* In implementations with reference counting, a consistent object
|
||||||
automatically) must be built before any exception is raised by user
|
(that will be deallocated automatically) must be built before any
|
||||||
code (for example the 'map' built-in function may run user code).
|
exception is raised by user code (for example the 'map' built-in
|
||||||
|
function may run user code). Garbage collection simplifies a lot
|
||||||
|
this kind of situations.
|
||||||
|
|
||||||
* Each module encapsulating dynamic allocation counts allocations and
|
* Each module encapsulating dynamic allocation counts allocations and
|
||||||
deallocations. With debugging options, a failure is reported if
|
deallocations. With debugging options, a failure is reported if
|
||||||
- too many deallocation happen (via a numeric range check)
|
- too many deallocation happen (via a numeric range check)
|
||||||
- all storage is not freed (via a dedicated call from the step file)
|
- all storage is not freed (via a dedicated call from the step file)
|
||||||
|
|
||||||
|
The main program only checks that the garbage collector removes all
|
||||||
|
allocations at the end of execution.
|
||||||
|
|
||||||
Debugging
|
Debugging
|
||||||
--
|
--
|
||||||
|
|
||||||
@ -61,7 +66,5 @@ TCO cycles). This has become possible in step9, but has been
|
|||||||
backported to former steps as this is really handy for debugging.
|
backported to former steps as this is really handy for debugging.
|
||||||
|
|
||||||
Some environment variables increase verbosity.
|
Some environment variables increase verbosity.
|
||||||
# dbg_reader= ./stepAmal trace reader recursion
|
# dbgread= ./stepAmal trace reader recursion
|
||||||
# dbgeval= ./stepAmal eval recursion (or TCO)
|
# dbgeval= ./stepAmal trace eval recursion (including TCO)
|
||||||
# dbgenv0= ./stepAmal eval recursion and environments contents
|
|
||||||
# dbgenv1= ./stepAmal eval recursion and environment internals
|
|
||||||
|
@ -3,11 +3,10 @@ with Ada.Characters.Latin_1;
|
|||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
|
|
||||||
with Envs;
|
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
|
||||||
with Types.Atoms;
|
with Types.Atoms;
|
||||||
with Types.Builtins;
|
with Types.Builtins;
|
||||||
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
with Types.Sequences;
|
with Types.Sequences;
|
||||||
@ -64,7 +63,6 @@ package body Core is
|
|||||||
function Apply (Args : in Mal.T_Array) return Mal.T;
|
function Apply (Args : in Mal.T_Array) return Mal.T;
|
||||||
function Division is new Generic_Mal_Operator ("/");
|
function Division is new Generic_Mal_Operator ("/");
|
||||||
function Equals (Args : in Mal.T_Array) return Mal.T;
|
function Equals (Args : in Mal.T_Array) return Mal.T;
|
||||||
function Eval (Args : in Mal.T_Array) return Mal.T;
|
|
||||||
function Greater_Equal is new Generic_Comparison (">=");
|
function Greater_Equal is new Generic_Comparison (">=");
|
||||||
function Greater_Than is new Generic_Comparison (">");
|
function Greater_Than is new Generic_Comparison (">");
|
||||||
function Is_Atom is new Generic_Kind_Test (Kind_Atom);
|
function Is_Atom is new Generic_Kind_Test (Kind_Atom);
|
||||||
@ -108,19 +106,19 @@ package body Core is
|
|||||||
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
|
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
|
||||||
"last parameter must be a sequence");
|
"last parameter must be a sequence");
|
||||||
declare
|
declare
|
||||||
use type Sequences.Ptr;
|
use type Sequences.Instance;
|
||||||
F : Mal.T renames Args (Args'First);
|
F : Mal.T renames Args (Args'First);
|
||||||
A : constant Mal.T_Array
|
A : constant Mal.T_Array
|
||||||
:= Args (Args'First + 1 .. Args'Last - 1)
|
:= Args (Args'First + 1 .. Args'Last - 1)
|
||||||
& Args (Args'Last).Sequence;
|
& Args (Args'Last).Sequence.all;
|
||||||
begin
|
begin
|
||||||
case F.Kind is
|
case F.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
return F.Builtin.all (A);
|
return F.Builtin.all (A);
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
return F.Builtin_With_Meta.Builtin.all (A);
|
return F.Builtin_With_Meta.all.Builtin.all (A);
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
return F.Fn.Apply (A);
|
return F.Fn.all.Apply (A);
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("parameter 1 must be a function");
|
Err.Raise_With ("parameter 1 must be a function");
|
||||||
end case;
|
end case;
|
||||||
@ -134,13 +132,6 @@ package body Core is
|
|||||||
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
|
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
|
||||||
end Equals;
|
end Equals;
|
||||||
|
|
||||||
function Eval (Args : in Mal.T_Array) return Mal.T is
|
|
||||||
begin
|
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
|
||||||
return Eval_Cb.Cb.all (Ast => Args (Args'First),
|
|
||||||
Env => Envs.Repl);
|
|
||||||
end Eval;
|
|
||||||
|
|
||||||
function Is_False (Args : in Mal.T_Array) return Mal.T is
|
function Is_False (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
@ -188,13 +179,13 @@ package body Core is
|
|||||||
begin
|
begin
|
||||||
case A1.Kind is
|
case A1.Kind is
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
return A1.Sequence.Meta;
|
return A1.Sequence.all.Meta;
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return A1.Map.Meta;
|
return A1.Map.all.Meta;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
return A1.Fn.Meta;
|
return A1.Fn.all.Meta;
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
return A1.Builtin_With_Meta.Meta;
|
return A1.Builtin_With_Meta.all.Meta;
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
when others =>
|
when others =>
|
||||||
@ -203,14 +194,14 @@ package body Core is
|
|||||||
end;
|
end;
|
||||||
end Meta;
|
end Meta;
|
||||||
|
|
||||||
procedure NS_Add_To_Repl is
|
procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is
|
||||||
procedure P (S : in Symbols.Ptr;
|
procedure P (S : in Symbols.Ptr;
|
||||||
B : in Mal.Builtin_Ptr) with Inline;
|
B : in Mal.Builtin_Ptr) with Inline;
|
||||||
procedure P (S : in Symbols.Ptr;
|
procedure P (S : in Symbols.Ptr;
|
||||||
B : in Mal.Builtin_Ptr)
|
B : in Mal.Builtin_Ptr)
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
Envs.Repl.Set (S, (Kind_Builtin, B));
|
Repl.all.Set (S, (Kind_Builtin, B));
|
||||||
end P;
|
end P;
|
||||||
begin
|
begin
|
||||||
P (Symbols.Constructor ("+"), Addition'Access);
|
P (Symbols.Constructor ("+"), Addition'Access);
|
||||||
@ -227,7 +218,6 @@ package body Core is
|
|||||||
P (Symbols.Constructor ("/"), Division'Access);
|
P (Symbols.Constructor ("/"), Division'Access);
|
||||||
P (Symbols.Constructor ("do"), Mal_Do'Access);
|
P (Symbols.Constructor ("do"), Mal_Do'Access);
|
||||||
P (Symbols.Constructor ("="), Equals'Access);
|
P (Symbols.Constructor ("="), Equals'Access);
|
||||||
P (Symbols.Constructor ("eval"), Eval'Access);
|
|
||||||
P (Symbols.Constructor ("first"), Sequences.First'Access);
|
P (Symbols.Constructor ("first"), Sequences.First'Access);
|
||||||
P (Symbols.Constructor ("get"), Maps.Get'Access);
|
P (Symbols.Constructor ("get"), Maps.Get'Access);
|
||||||
P (Symbols.Constructor (">="), Greater_Equal'Access);
|
P (Symbols.Constructor (">="), Greater_Equal'Access);
|
||||||
@ -360,7 +350,7 @@ package body Core is
|
|||||||
end;
|
end;
|
||||||
end if;
|
end if;
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
if Args (Args'First).Sequence.Length = 0 then
|
if Args (Args'First).Sequence.all.Length = 0 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
return (Kind_List, Args (Args'First).Sequence);
|
return (Kind_List, Args (Args'First).Sequence);
|
||||||
@ -427,17 +417,17 @@ package body Core is
|
|||||||
begin
|
begin
|
||||||
case A1.Kind is
|
case A1.Kind is
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
return A1.Builtin_With_Meta.With_Meta (A2);
|
return Builtins.With_Meta (A1.Builtin_With_Meta.all, A2);
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
return Builtins.With_Meta (A1.Builtin, A2);
|
return Builtins.With_Meta (A1.Builtin, A2);
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
return (Kind_List, A1.Sequence.With_Meta (A2));
|
return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2));
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, A1.Sequence.With_Meta (A2));
|
return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2));
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return A1.Map.With_Meta (A2);
|
return Maps.With_Meta (A1.Map.all, A2);
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
return A1.Fn.With_Meta (A2);
|
return Fns.With_Meta (A1.Fn.all, A2);
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With
|
Err.Raise_With
|
||||||
("parameter 1 must be a function, map or sequence");
|
("parameter 1 must be a function, map or sequence");
|
||||||
|
@ -1,6 +1,8 @@
|
|||||||
|
with Envs;
|
||||||
|
|
||||||
package Core with Elaborate_Body is
|
package Core with Elaborate_Body is
|
||||||
|
|
||||||
procedure NS_Add_To_Repl;
|
procedure NS_Add_To_Repl (Repl : in Envs.Ptr);
|
||||||
-- Add built-in functions to Envs.Repl.
|
-- Add built-in functions.
|
||||||
|
|
||||||
end Core;
|
end Core;
|
||||||
|
454
ada.2/envs.adb
454
ada.2/envs.adb
@ -1,6 +1,4 @@
|
|||||||
with Ada.Containers.Hashed_Maps;
|
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
with Printer;
|
with Printer;
|
||||||
@ -11,417 +9,93 @@ package body Envs is
|
|||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
|
|
||||||
-- The Eval built-in uses the REPL root environment (index 1),
|
|
||||||
-- all others parameters only repeat the top index.
|
|
||||||
|
|
||||||
package HM is new Ada.Containers.Hashed_Maps
|
|
||||||
(Key_Type => Symbols.Ptr,
|
|
||||||
Element_Type => Mal.T,
|
|
||||||
Hash => Symbols.Hash,
|
|
||||||
Equivalent_Keys => Symbols."=",
|
|
||||||
"=" => Mal."=");
|
|
||||||
|
|
||||||
type Stack_Record
|
|
||||||
(Outer_On_Stack : Boolean := True) is record
|
|
||||||
Data : HM.Map := HM.Empty_Map;
|
|
||||||
Refs : Natural := 1;
|
|
||||||
-- Only references via the Ptr type.
|
|
||||||
-- References from the stack or Alias are not counted here.
|
|
||||||
Alias : Heap_Access := null;
|
|
||||||
-- Used by the closures and heap records to refer to this stack
|
|
||||||
-- record, so that if it moves to the heap we only need to
|
|
||||||
-- update the alias.
|
|
||||||
case Outer_On_Stack is
|
|
||||||
when True =>
|
|
||||||
Outer_Index : Stack_Index := 0;
|
|
||||||
when False =>
|
|
||||||
Outer_Ref : Heap_Access := null;
|
|
||||||
end case;
|
|
||||||
end record
|
|
||||||
with Dynamic_Predicate => 0 < Refs
|
|
||||||
and (Alias = null or else Alias.all.Outer = null)
|
|
||||||
and (if Outer_On_Stack
|
|
||||||
then Outer_Index <= Top
|
|
||||||
else Outer_Ref /= null);
|
|
||||||
|
|
||||||
-- It is forbidden to change the discriminant of an access type,
|
|
||||||
-- so we cannot use a discriminant here.
|
|
||||||
type Heap_Record is limited record
|
|
||||||
Refs : Natural := 1;
|
|
||||||
Data : HM.Map := HM.Empty_Map;
|
|
||||||
Index : Stack_Index;
|
|
||||||
Outer : Heap_Access := null;
|
|
||||||
end record
|
|
||||||
with Dynamic_Predicate =>
|
|
||||||
(if Outer = null
|
|
||||||
then Index in 1 .. Top and Data.Is_Empty
|
|
||||||
else 0 < Refs);
|
|
||||||
-- Either an alias for a stack element or an actual environment.
|
|
||||||
|
|
||||||
-- There could be one single type, but this would enlarge the
|
|
||||||
-- stack without simplifying the code, and prevent some more
|
|
||||||
-- static type checking.
|
|
||||||
|
|
||||||
Stack : array (Stack_Index range 1 .. Stack_Index'Last) of Stack_Record;
|
|
||||||
-- The default value gives a consistent value to Stack (1),
|
|
||||||
-- compatible with the Repl constant.
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Heap_Record, Heap_Access);
|
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
procedure Unreference (Reference : in out Heap_Access);
|
|
||||||
|
|
||||||
procedure Set_Binds (M : in out HM.Map;
|
|
||||||
Binds : in Symbols.Symbol_Array;
|
|
||||||
Exprs : in Mal.T_Array);
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
procedure Adjust (Object : in out Closure_Ptr) is
|
procedure Dump_Stack (Env : in Instance) is
|
||||||
begin
|
|
||||||
if Object.Ref /= null then
|
|
||||||
Object.Ref.all.Refs := @ + 1;
|
|
||||||
end if;
|
|
||||||
end Adjust;
|
|
||||||
|
|
||||||
procedure Clear_And_Check_Allocations is
|
|
||||||
begin
|
|
||||||
pragma Assert (Top = 1);
|
|
||||||
pragma Assert (Stack (1).Refs = 1);
|
|
||||||
Stack (1).Data.Clear;
|
|
||||||
if Stack (1).Alias /= null then
|
|
||||||
if Stack (1).Alias.all.Refs /= 0 then
|
|
||||||
Dump_Stack (Long => True);
|
|
||||||
end if;
|
|
||||||
pragma Assert (Stack (1).Alias.all.Refs = 0);
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Stack (1).Alias);
|
|
||||||
end if;
|
|
||||||
pragma Assert (Allocations = 0);
|
|
||||||
end Clear_And_Check_Allocations;
|
|
||||||
|
|
||||||
function Copy_Pointer (Env : in Ptr) return Ptr is
|
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
|
||||||
begin
|
|
||||||
Stack (Env.Index).Refs := @ + 1;
|
|
||||||
return (Ada.Finalization.Limited_Controlled with Env.Index);
|
|
||||||
end Copy_Pointer;
|
|
||||||
|
|
||||||
procedure Dump_Stack (Long : in Boolean) is
|
|
||||||
use Ada.Text_IO;
|
use Ada.Text_IO;
|
||||||
begin
|
begin
|
||||||
for I in 1 .. Top loop
|
Put_Line ("environment:");
|
||||||
if Long then
|
for P in Env.Data.Iterate loop
|
||||||
Put ("Level");
|
-- Do not print builtins for repl.
|
||||||
end if;
|
if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then
|
||||||
Put (I'Img);
|
Put (" ");
|
||||||
if Long then
|
Put (HM.Key (P).To_String);
|
||||||
|
Put (':');
|
||||||
|
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
|
||||||
New_Line;
|
New_Line;
|
||||||
Put_Line (" refs=" & Stack (I).Refs'Img);
|
|
||||||
if Stack (I).Alias = null then
|
|
||||||
Put_Line (" no alias");
|
|
||||||
else
|
|
||||||
Put_Line (" an alias with" & Stack (I).Alias.all.Refs'Img
|
|
||||||
& " refs");
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
if Long then
|
|
||||||
Put (" outer=");
|
|
||||||
else
|
|
||||||
Put (" (->");
|
|
||||||
end if;
|
|
||||||
if Stack (I).Outer_On_Stack then
|
|
||||||
Put (Stack (I).Outer_Index'Img);
|
|
||||||
elsif Stack (I).Outer_Ref.all.Outer = null then
|
|
||||||
if Long then
|
|
||||||
Put ("alias for ");
|
|
||||||
end if;
|
|
||||||
Put (Stack (I).Outer_Ref.all.Index'Img);
|
|
||||||
else
|
|
||||||
Put (" closure for ex " & Stack (I).Outer_Ref.all.Index'Img);
|
|
||||||
end if;
|
|
||||||
if Long then
|
|
||||||
New_Line;
|
|
||||||
else
|
|
||||||
Put ("):");
|
|
||||||
end if;
|
|
||||||
for P in Stack (I).Data.Iterate loop
|
|
||||||
if HM.Element (P).Kind /= Kind_Builtin or 1 < I then
|
|
||||||
Put (" ");
|
|
||||||
Put (HM.Key (P).To_String);
|
|
||||||
Put (':');
|
|
||||||
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
|
|
||||||
if Long then
|
|
||||||
New_Line;
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end loop;
|
|
||||||
New_Line;
|
|
||||||
end loop;
|
end loop;
|
||||||
|
if Env.Outer /= null then
|
||||||
|
Put ("outer is ");
|
||||||
|
Env.Outer.all.Dump_Stack;
|
||||||
|
end if;
|
||||||
end Dump_Stack;
|
end Dump_Stack;
|
||||||
|
|
||||||
procedure Finalize (Object : in out Closure_Ptr) is
|
function Get (Env : in Instance;
|
||||||
begin
|
|
||||||
Unreference (Object.Ref);
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
if 0 < Object.Index then
|
|
||||||
if 0 < Stack (Object.Index).Refs then
|
|
||||||
Stack (Object.Index).Refs := @ - 1;
|
|
||||||
end if;
|
|
||||||
Object.Index := 0;
|
|
||||||
|
|
||||||
-- If Index = Top and there are no more references.
|
|
||||||
loop
|
|
||||||
pragma Assert (0 < Top);
|
|
||||||
declare
|
|
||||||
R : Stack_Record renames Stack (Top);
|
|
||||||
begin
|
|
||||||
exit when 0 < R.Refs;
|
|
||||||
|
|
||||||
if Top = 1 then
|
|
||||||
R.Data.Clear;
|
|
||||||
if R.Alias /= null then
|
|
||||||
pragma Assert (R.Alias.all.Outer = null);
|
|
||||||
pragma Assert (R.Alias.all.Refs = 0);
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (R.Alias);
|
|
||||||
end if;
|
|
||||||
exit;
|
|
||||||
elsif R.Alias = null then
|
|
||||||
R.Data.Clear;
|
|
||||||
if not R.Outer_On_Stack then
|
|
||||||
Unreference (R.Outer_Ref);
|
|
||||||
end if;
|
|
||||||
elsif R.Alias.all.Refs = 0 then
|
|
||||||
pragma Assert (R.Alias.all.Outer = null);
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (R.Alias);
|
|
||||||
R.Data.Clear;
|
|
||||||
if not R.Outer_On_Stack then
|
|
||||||
Unreference (R.Outer_Ref);
|
|
||||||
end if;
|
|
||||||
else
|
|
||||||
-- Detach this environment from the stack.
|
|
||||||
|
|
||||||
-- The reference count is already correct.
|
|
||||||
|
|
||||||
-- Copy the hashmap contents without reallocation..
|
|
||||||
R.Alias.all.Data.Move (R.Data);
|
|
||||||
|
|
||||||
-- The Index will not be used anymore.
|
|
||||||
|
|
||||||
-- We need the parent to have an alias, in case it
|
|
||||||
-- must be detached later.
|
|
||||||
if R.Outer_On_Stack then
|
|
||||||
declare
|
|
||||||
O : Stack_Record renames Stack (R.Outer_Index);
|
|
||||||
begin
|
|
||||||
if O.Alias = null then
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
O.Alias := new Heap_Record'(Index => R.Outer_Index,
|
|
||||||
others => <>);
|
|
||||||
else
|
|
||||||
O.Alias.all.Refs := @ + 1;
|
|
||||||
end if;
|
|
||||||
R.Alias.all.Outer := O.Alias;
|
|
||||||
end;
|
|
||||||
else
|
|
||||||
R.Alias.all.Outer := R.Outer_Ref;
|
|
||||||
end if;
|
|
||||||
R.Alias := null;
|
|
||||||
end if;
|
|
||||||
end;
|
|
||||||
Top := Top - 1;
|
|
||||||
end loop;
|
|
||||||
end if;
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
function Get (Evt : in Ptr;
|
|
||||||
Key : in Symbols.Ptr) return Mal.T
|
Key : in Symbols.Ptr) return Mal.T
|
||||||
is
|
is
|
||||||
pragma Assert (Evt.Index in 1 | Top);
|
-- Trust the compiler to detect the tail call. A loop would
|
||||||
Index : Stack_Index := Evt.Index;
|
-- require a Ptr parameter or a separated first iteration.
|
||||||
Ref : Heap_Access;
|
Position : constant HM.Cursor := Env.Data.Find (Key);
|
||||||
Definition : HM.Cursor;
|
|
||||||
begin
|
begin
|
||||||
Main_Loop : loop
|
if HM.Has_Element (Position) then
|
||||||
Index_Loop : loop
|
return HM.Element (Position);
|
||||||
Definition := Stack (Index).Data.Find (Key);
|
end if;
|
||||||
if HM.Has_Element (Definition) then
|
Err.Check (Env.Outer /= null,
|
||||||
return HM.Element (Definition);
|
"'" & Symbols.To_String (Key) & "' not found");
|
||||||
end if;
|
return Env.Outer.all.Get (Key);
|
||||||
exit Index_Loop when not Stack (Index).Outer_On_Stack;
|
|
||||||
Index := Stack (Index).Outer_Index;
|
|
||||||
exit Main_Loop when Index = 0;
|
|
||||||
end loop Index_Loop;
|
|
||||||
Ref := Stack (Index).Outer_Ref;
|
|
||||||
Ref_Loop : loop
|
|
||||||
Definition := Ref.all.Data.Find (Key);
|
|
||||||
if HM.Has_Element (Definition) then
|
|
||||||
return HM.Element (Definition);
|
|
||||||
end if;
|
|
||||||
exit Ref_Loop when Ref.all.Outer = null;
|
|
||||||
Ref := Ref.all.Outer;
|
|
||||||
end loop Ref_Loop;
|
|
||||||
Index := Ref.all.Index;
|
|
||||||
end loop Main_Loop;
|
|
||||||
Err.Raise_With ("'" & Key.To_String & "' not found");
|
|
||||||
end Get;
|
end Get;
|
||||||
|
|
||||||
function New_Closure (Env : in Ptr'Class) return Closure_Ptr is
|
procedure Keep_References (Object : in out Instance) is
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
-- Same remarks than for Get.
|
||||||
Alias : Heap_Access renames Stack (Env.Index).Alias;
|
|
||||||
begin
|
begin
|
||||||
if Alias = null then
|
for Element of Object.Data loop
|
||||||
Allocations := Allocations + 1;
|
Mal.Keep (Element);
|
||||||
Alias := new Heap_Record'(Index => Env.Index, others => <>);
|
end loop;
|
||||||
else
|
if Object.Outer /= null then
|
||||||
Alias.all.Refs := @ + 1;
|
Object.Outer.all.Keep;
|
||||||
end if;
|
end if;
|
||||||
return (Ada.Finalization.Controlled with Alias);
|
end Keep_References;
|
||||||
end New_Closure;
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr) is
|
function New_Env (Outer : in Ptr := null;
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
Binds : in Symbols.Symbol_Array := No_Binds;
|
||||||
R : Stack_Record renames Stack (Env.Index);
|
Exprs : in Mal.T_Array := No_Exprs) return Ptr
|
||||||
begin
|
|
||||||
if Env.Index < Top or 1 < R.Refs
|
|
||||||
or (R.Alias /= null and then 0 < R.Alias.all.Refs)
|
|
||||||
then
|
|
||||||
R.Refs := @ - 1;
|
|
||||||
Top := Top + 1;
|
|
||||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
|
||||||
pragma Assert (Stack (Top).Alias = null);
|
|
||||||
Stack (Top) := (Outer_Index => Env.Index,
|
|
||||||
others => <>);
|
|
||||||
Env.Index := Top;
|
|
||||||
end if;
|
|
||||||
-- Else reuse the top stack record, including its map and its
|
|
||||||
-- unreferenced alias if any.
|
|
||||||
end Replace_With_Sub;
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr;
|
|
||||||
Outer : in Closure_Ptr'Class;
|
|
||||||
Binds : in Symbols.Symbol_Array;
|
|
||||||
Exprs : in Mal.T_Array)
|
|
||||||
is
|
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
|
||||||
begin
|
|
||||||
-- Finalize Env before creating the new environment, in case
|
|
||||||
-- this is the last reference and it can be forgotten.
|
|
||||||
-- Automatic assignment would construct the new value before
|
|
||||||
-- finalizing the old one.
|
|
||||||
Finalize (Env);
|
|
||||||
Outer.Ref.all.Refs := @ + 1;
|
|
||||||
Top := Top + 1;
|
|
||||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
|
||||||
pragma Assert (Stack (Top).Alias = null);
|
|
||||||
Stack (Top) := (Outer_On_Stack => False,
|
|
||||||
Outer_Ref => Outer.Ref,
|
|
||||||
others => <>);
|
|
||||||
Env.Index := Top;
|
|
||||||
-- Now we can afford raising exceptions.
|
|
||||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
|
||||||
end Replace_With_Sub;
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr;
|
|
||||||
Binds : in Symbols.Symbol_Array;
|
|
||||||
Exprs : in Mal.T_Array)
|
|
||||||
is
|
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
|
||||||
begin
|
|
||||||
Replace_With_Sub (Env);
|
|
||||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
|
||||||
end Replace_With_Sub;
|
|
||||||
|
|
||||||
procedure Set (Env : in Ptr;
|
|
||||||
Key : in Symbols.Ptr;
|
|
||||||
New_Element : in Mal.T)
|
|
||||||
is
|
|
||||||
pragma Assert (Env.Index in 1 | Top);
|
|
||||||
begin
|
|
||||||
Stack (Env.Index).Data.Include (Key, New_Element);
|
|
||||||
end Set;
|
|
||||||
|
|
||||||
procedure Set_Binds (M : in out HM.Map;
|
|
||||||
Binds : in Symbols.Symbol_Array;
|
|
||||||
Exprs : in Mal.T_Array)
|
|
||||||
is
|
is
|
||||||
use type Symbols.Ptr;
|
use type Symbols.Ptr;
|
||||||
Varargs : constant Boolean := 1 < Binds'Length and then
|
Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with
|
||||||
Binds (Binds'Last - 1) = Symbols.Names.Ampersand;
|
Outer => Outer,
|
||||||
|
Data => HM.Empty_Map);
|
||||||
begin
|
begin
|
||||||
Err.Check ((if Varargs then Binds'Length - 2 <= Exprs'Length
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
else Exprs'Length = Binds'Length),
|
if 2 <= Binds'Length
|
||||||
"actual parameters do not match formal parameters");
|
and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand
|
||||||
for I in 0 .. Binds'Length - (if Varargs then 3 else 1) loop
|
then
|
||||||
M.Include (Binds (Binds'First + I), Exprs (Exprs'First + I));
|
Err.Check (Binds'Length - 2 <= Exprs'Length,
|
||||||
end loop;
|
"not enough actual parameters for vararg function");
|
||||||
if Varargs then
|
for I in 0 .. Binds'Length - 3 loop
|
||||||
M.Include (Binds (Binds'Last), Sequences.List
|
Ref.all.Data.Include (Key => Binds (Binds'First + I),
|
||||||
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
|
New_Item => Exprs (Exprs'First + I));
|
||||||
|
end loop;
|
||||||
|
Ref.all.Data.Include (Key => Binds (Binds'Last),
|
||||||
|
New_Item => Sequences.List
|
||||||
|
(Exprs (Exprs'First + Binds'Length - 2 .. Exprs'Last)));
|
||||||
|
else
|
||||||
|
Err.Check (Binds'Length = Exprs'Length,
|
||||||
|
"wrong parameter count for (not vararg) function");
|
||||||
|
for I in 0 .. Binds'Length - 1 loop
|
||||||
|
Ref.all.Data.Include (Key => Binds (Binds'First + I),
|
||||||
|
New_Item => Exprs (Exprs'First + I));
|
||||||
|
end loop;
|
||||||
end if;
|
end if;
|
||||||
end Set_Binds;
|
return Ref;
|
||||||
|
end New_Env;
|
||||||
|
|
||||||
function Sub (Outer : in Ptr;
|
procedure Set (Env : in out Instance;
|
||||||
Binds : in Symbols.Symbol_Array;
|
Key : in Symbols.Ptr;
|
||||||
Exprs : in Mal.T_Array) return Ptr
|
New_Item : in Mal.T)
|
||||||
is
|
|
||||||
pragma Assert (Outer.Index in 1 | Top);
|
|
||||||
begin
|
|
||||||
Top := Top + 1;
|
|
||||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
|
||||||
pragma Assert (Stack (Top).Alias = null);
|
|
||||||
Stack (Top) := (Outer_Index => Outer.Index,
|
|
||||||
others => <>);
|
|
||||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
|
||||||
return (Ada.Finalization.Limited_Controlled with Top);
|
|
||||||
end Sub;
|
|
||||||
|
|
||||||
function Sub (Outer : in Closure_Ptr'Class;
|
|
||||||
Binds : in Symbols.Symbol_Array;
|
|
||||||
Exprs : in Mal.T_Array) return Ptr
|
|
||||||
is
|
is
|
||||||
begin
|
begin
|
||||||
Outer.Ref.all.Refs := @ + 1;
|
Env.Data.Include (Key, New_Item);
|
||||||
Top := Top + 1;
|
end Set;
|
||||||
pragma Assert (Stack (Top).Data.Is_Empty);
|
|
||||||
pragma Assert (Stack (Top).Alias = null);
|
|
||||||
Stack (Top) := (Outer_On_Stack => False,
|
|
||||||
Outer_Ref => Outer.Ref,
|
|
||||||
others => <>);
|
|
||||||
-- Take care to construct the result before raising any
|
|
||||||
-- exception, so that it is finalized correctly.
|
|
||||||
return R : constant Ptr := (Ada.Finalization.Limited_Controlled with Top)
|
|
||||||
do
|
|
||||||
-- Now we can afford raising exceptions.
|
|
||||||
Set_Binds (Stack (Top).Data, Binds, Exprs);
|
|
||||||
end return;
|
|
||||||
end Sub;
|
|
||||||
|
|
||||||
procedure Unreference (Reference : in out Heap_Access) is
|
|
||||||
Ref : Heap_Access := Reference;
|
|
||||||
begin
|
|
||||||
Reference := null;
|
|
||||||
loop
|
|
||||||
exit when Ref = null;
|
|
||||||
exit when Ref.all.Refs = 0;
|
|
||||||
Ref.all.Refs := @ - 1;
|
|
||||||
exit when 0 < Ref.all.Refs;
|
|
||||||
exit when Ref.all.Outer = null; -- An alias. Do not free it
|
|
||||||
-- now, it may be useful for another closure.
|
|
||||||
declare
|
|
||||||
Tmp : Heap_Access := Ref;
|
|
||||||
begin
|
|
||||||
Ref := Ref.all.Outer;
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Tmp);
|
|
||||||
pragma Unreferenced (Tmp);
|
|
||||||
end;
|
|
||||||
end loop;
|
|
||||||
end Unreference;
|
|
||||||
|
|
||||||
end Envs;
|
end Envs;
|
||||||
|
143
ada.2/envs.ads
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.Mal;
|
||||||
with Types.Symbols;
|
with Types.Symbols;
|
||||||
|
|
||||||
package Envs with Elaborate_Body is
|
package Envs is
|
||||||
|
|
||||||
-- This package should be named Env, but Ada does not allow formal
|
-- This package should be named Env, but Ada does not allow formal
|
||||||
-- parameters to be named like a package dependency, and it seems
|
-- parameters to be named like a package dependency, and it seems
|
||||||
-- that readability inside Eval is more important.
|
-- that readability inside Eval is more important.
|
||||||
|
|
||||||
-- This implementation relies on the fact that the caller only
|
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||||
-- ever references environments in its execution stack.
|
type Ptr is access Instance;
|
||||||
|
|
||||||
-- When a function closure references an environment that the
|
No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array;
|
||||||
-- execution leaves behind, a dynamically allocated block is used
|
No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil);
|
||||||
-- instead.
|
|
||||||
|
|
||||||
-- The eval built-in requires REPL (see the implementation of
|
function New_Env (Outer : in Ptr := null;
|
||||||
-- load-file), so we cannot assume that the caller only sees the
|
Binds : in Types.Symbols.Symbol_Array := No_Binds;
|
||||||
-- current environment.
|
Exprs : in Types.Mal.T_Array := No_Exprs)
|
||||||
|
return Ptr;
|
||||||
|
|
||||||
type Ptr (<>) is tagged limited private;
|
function Get (Env : in Instance;
|
||||||
-- This type is controlled in order count the references to a
|
|
||||||
-- given environment, even during exception propagation.
|
|
||||||
-- Since Ptr is limited with a hidden discriminant, any variable
|
|
||||||
-- must immediately be assigned with one of
|
|
||||||
-- * Copy_Pointer,
|
|
||||||
-- * Sub (either from a Ptr or from a Closure_Ptr).
|
|
||||||
-- Usual assignment with reference counting is not provided
|
|
||||||
-- because we want to enforce the use of the more efficient
|
|
||||||
-- Replace_With_Sub.
|
|
||||||
|
|
||||||
Repl : constant Ptr;
|
|
||||||
-- The top environment.
|
|
||||||
|
|
||||||
function Copy_Pointer (Env : in Ptr) return Ptr with Inline;
|
|
||||||
-- Allows assignment to a freshly created variable. This is
|
|
||||||
-- required for tail call optimization, but should be avoided
|
|
||||||
-- elsewhere.
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr) with Inline;
|
|
||||||
-- for let*
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr;
|
|
||||||
Binds : in Types.Symbols.Symbol_Array;
|
|
||||||
Exprs : in Types.Mal.T_Array) with Inline;
|
|
||||||
-- when expanding macros.
|
|
||||||
|
|
||||||
procedure Set (Env : in Ptr;
|
|
||||||
Key : in Types.Symbols.Ptr;
|
|
||||||
New_Element : in Types.Mal.T)
|
|
||||||
with Inline;
|
|
||||||
|
|
||||||
-- The Find method is merged into the Get method.
|
|
||||||
|
|
||||||
function Get (Evt : in Ptr;
|
|
||||||
Key : in Types.Symbols.Ptr) return Types.Mal.T;
|
Key : in Types.Symbols.Ptr) return Types.Mal.T;
|
||||||
-- Raises Core.Error_Exception if the key is not found.
|
|
||||||
|
|
||||||
-- Function closures.
|
procedure Set (Env : in out Instance;
|
||||||
|
Key : in Types.Symbols.Ptr;
|
||||||
|
New_Item : in Types.Mal.T) with Inline;
|
||||||
|
|
||||||
type Closure_Ptr is tagged private;
|
-- Debug.
|
||||||
Null_Closure : constant Closure_Ptr;
|
procedure Dump_Stack (Env : in Instance);
|
||||||
|
|
||||||
function New_Closure (Env : in Ptr'Class) return Closure_Ptr;
|
|
||||||
-- The class-wide argument does not make much sense, but avoids
|
|
||||||
-- the compiler wondering on which type is should dispatch.
|
|
||||||
|
|
||||||
function Sub (Outer : in Closure_Ptr'Class;
|
|
||||||
Binds : in Types.Symbols.Symbol_Array;
|
|
||||||
Exprs : in Types.Mal.T_Array) return Ptr;
|
|
||||||
-- when applying functions without tail call optimization.
|
|
||||||
-- Construct a new environment with the given outer parent.
|
|
||||||
-- Then call Set with the paired elements of Binds and Exprs,
|
|
||||||
-- handling the "&" special formal parameter if present.
|
|
||||||
-- May raise Error.
|
|
||||||
|
|
||||||
procedure Replace_With_Sub (Env : in out Ptr;
|
|
||||||
Outer : in Closure_Ptr'Class;
|
|
||||||
Binds : in Types.Symbols.Symbol_Array;
|
|
||||||
Exprs : in Types.Mal.T_Array);
|
|
||||||
-- when applying functions with tail call optimization.
|
|
||||||
-- Equivalent to Env := Sub (Env, Binds, Exprs), except that such
|
|
||||||
-- an assignment is forbidden or discouraged for performance reasons.
|
|
||||||
|
|
||||||
function Sub (Outer : in Ptr;
|
|
||||||
Binds : in Types.Symbols.Symbol_Array;
|
|
||||||
Exprs : in Types.Mal.T_Array) return Ptr;
|
|
||||||
-- when applying macros
|
|
||||||
|
|
||||||
-- Debugging.
|
|
||||||
procedure Dump_Stack (Long : in Boolean);
|
|
||||||
procedure Clear_And_Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
-- There must be a reference level so that functions may keep
|
package HM is new Ada.Containers.Hashed_Maps
|
||||||
-- track of their initial environment, and another one for
|
(Key_Type => Types.Symbols.Ptr,
|
||||||
-- reallocations. The second one is delegated to a predefined Ada
|
Element_Type => Types.Mal.T,
|
||||||
-- container.
|
Hash => Types.Symbols.Hash,
|
||||||
|
Equivalent_Keys => Types.Symbols."=",
|
||||||
|
"=" => Types.Mal."=");
|
||||||
|
|
||||||
-- MAL maps may be tempting, but we do not want to copy the whole
|
type Instance is new Garbage_Collected.Instance with record
|
||||||
-- map for each addition or removal.
|
Outer : Ptr;
|
||||||
|
Data : HM.Map;
|
||||||
-- Some tests seem to show that a hashmap is three times faster
|
|
||||||
-- than a vector with (key, value) couples.
|
|
||||||
|
|
||||||
-- We allow the null value so that the empty environment in a
|
|
||||||
-- macro does not trigger an allocation.
|
|
||||||
|
|
||||||
type Stack_Index is range 0 .. 200;
|
|
||||||
|
|
||||||
-- See README for the implementation of reference counting.
|
|
||||||
|
|
||||||
type Ptr is new Ada.Finalization.Limited_Controlled with record
|
|
||||||
Index : Stack_Index := 0;
|
|
||||||
end record
|
|
||||||
with Invariant => Ptr.Index in 1 .. Top;
|
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
|
||||||
|
|
||||||
Top : Stack_Index := 1;
|
|
||||||
Repl : constant Ptr := (Ada.Finalization.Limited_Controlled with 1);
|
|
||||||
|
|
||||||
type Heap_Record;
|
|
||||||
type Heap_Access is access Heap_Record;
|
|
||||||
type Closure_Ptr is new Ada.Finalization.Controlled with record
|
|
||||||
Ref : Heap_Access := null;
|
|
||||||
end record;
|
end record;
|
||||||
overriding procedure Adjust (Object : in out Closure_Ptr) with Inline;
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
overriding procedure Finalize (Object : in out Closure_Ptr) with Inline;
|
|
||||||
pragma Finalize_Storage_Only (Closure_Ptr);
|
|
||||||
|
|
||||||
Null_Closure : constant Closure_Ptr
|
|
||||||
:= (Ada.Finalization.Controlled with null);
|
|
||||||
|
|
||||||
end Envs;
|
end Envs;
|
||||||
|
54
ada.2/garbage_collected.adb
Normal file
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.
|
-- Helpers for Print_Form.
|
||||||
procedure Print_Number (Number : in Integer) with Inline;
|
procedure Print_Number (Number : in Integer) with Inline;
|
||||||
procedure Print_List (List : in Sequences.Ptr) with Inline;
|
procedure Print_List (List : in Sequences.Instance) with Inline;
|
||||||
procedure Print_Map (Map : in Maps.Ptr) with Inline;
|
procedure Print_Map (Map : in Maps.Instance) with Inline;
|
||||||
procedure Print_Readably (S : in Unbounded_String) with Inline;
|
procedure Print_Readably (S : in Unbounded_String) with Inline;
|
||||||
procedure Print_Function (Fn : in Fns.Ptr) with Inline;
|
procedure Print_Function (Fn : in Fns.Instance) with Inline;
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
@ -41,7 +41,7 @@ package body Printer is
|
|||||||
Append (Buffer, "false");
|
Append (Buffer, "false");
|
||||||
end if;
|
end if;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
Append (Buffer, Form_Ast.Symbol.To_String);
|
Append (Buffer, Symbols.To_String (Form_Ast.Symbol));
|
||||||
when Kind_Number =>
|
when Kind_Number =>
|
||||||
Print_Number (Form_Ast.Number);
|
Print_Number (Form_Ast.Number);
|
||||||
when Kind_Keyword =>
|
when Kind_Keyword =>
|
||||||
@ -57,34 +57,34 @@ package body Printer is
|
|||||||
end if;
|
end if;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
Append (Buffer, '(');
|
Append (Buffer, '(');
|
||||||
Print_List (Form_Ast.Sequence);
|
Print_List (Form_Ast.Sequence.all);
|
||||||
Append (Buffer, ')');
|
Append (Buffer, ')');
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
Append (Buffer, '[');
|
Append (Buffer, '[');
|
||||||
Print_List (Form_Ast.Sequence);
|
Print_List (Form_Ast.Sequence.all);
|
||||||
Append (Buffer, ']');
|
Append (Buffer, ']');
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
Append (Buffer, '{');
|
Append (Buffer, '{');
|
||||||
Print_Map (Form_Ast.Map);
|
Print_Map (Form_Ast.Map.all);
|
||||||
Append (Buffer, '}');
|
Append (Buffer, '}');
|
||||||
when Kind_Builtin | Kind_Builtin_With_Meta =>
|
when Kind_Builtin | Kind_Builtin_With_Meta =>
|
||||||
Append (Buffer, "#<built-in>");
|
Append (Buffer, "#<built-in>");
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
Append (Buffer, "#<function (");
|
Append (Buffer, "#<function (");
|
||||||
Print_Function (Form_Ast.Fn);
|
Print_Function (Form_Ast.Fn.all);
|
||||||
Append (Buffer, '>');
|
Append (Buffer, '>');
|
||||||
when Kind_Macro =>
|
when Kind_Macro =>
|
||||||
Append (Buffer, "#<macro (");
|
Append (Buffer, "#<macro (");
|
||||||
Print_Function (Form_Ast.Fn);
|
Print_Function (Form_Ast.Fn.all);
|
||||||
Append (Buffer, '>');
|
Append (Buffer, '>');
|
||||||
when Kind_Atom =>
|
when Kind_Atom =>
|
||||||
Append (Buffer, "(atom ");
|
Append (Buffer, "(atom ");
|
||||||
Print_Form (Atoms.Deref (Form_Ast.Atom));
|
Print_Form (Form_Ast.Atom.all.Deref);
|
||||||
Append (Buffer, ')');
|
Append (Buffer, ')');
|
||||||
end case;
|
end case;
|
||||||
end Print_Form;
|
end Print_Form;
|
||||||
|
|
||||||
procedure Print_Function (Fn : in Fns.Ptr) is
|
procedure Print_Function (Fn : in Fns.Instance) is
|
||||||
Started : Boolean := False;
|
Started : Boolean := False;
|
||||||
begin
|
begin
|
||||||
Append (Buffer, '(');
|
Append (Buffer, '(');
|
||||||
@ -94,13 +94,13 @@ package body Printer is
|
|||||||
else
|
else
|
||||||
Started := True;
|
Started := True;
|
||||||
end if;
|
end if;
|
||||||
Append (Buffer, Param.To_String);
|
Append (Buffer, Symbols.To_String (Param));
|
||||||
end loop;
|
end loop;
|
||||||
Append (Buffer, ") -> ");
|
Append (Buffer, ") -> ");
|
||||||
Print_Form (Fn.Ast);
|
Print_Form (Fn.Ast);
|
||||||
end Print_Function;
|
end Print_Function;
|
||||||
|
|
||||||
procedure Print_List (List : in Sequences.Ptr) is
|
procedure Print_List (List : in Sequences.Instance) is
|
||||||
begin
|
begin
|
||||||
if 0 < List.Length then
|
if 0 < List.Length then
|
||||||
Print_Form (List (1));
|
Print_Form (List (1));
|
||||||
@ -111,7 +111,7 @@ package body Printer is
|
|||||||
end if;
|
end if;
|
||||||
end Print_List;
|
end Print_List;
|
||||||
|
|
||||||
procedure Print_Map (Map : in Maps.Ptr) is
|
procedure Print_Map (Map : in Maps.Instance) is
|
||||||
procedure Process (Key : in Mal.T;
|
procedure Process (Key : in Mal.T;
|
||||||
Element : in Mal.T) with Inline;
|
Element : in Mal.T) with Inline;
|
||||||
procedure Iterate is new Maps.Iterate (Process);
|
procedure Iterate is new Maps.Iterate (Process);
|
||||||
|
129
ada.2/reader.adb
129
ada.2/reader.adb
@ -13,7 +13,7 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
package body Reader is
|
package body Reader is
|
||||||
|
|
||||||
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbg_reader");
|
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread");
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Ada.Strings.Maps.Character_Set;
|
use type Ada.Strings.Maps.Character_Set;
|
||||||
@ -37,7 +37,7 @@ package body Reader is
|
|||||||
B_Last : Natural := Buffer'First - 1;
|
B_Last : Natural := Buffer'First - 1;
|
||||||
-- Index in Buffer of the currently written MAL expression.
|
-- Index in Buffer of the currently written MAL expression.
|
||||||
|
|
||||||
procedure Read_Form;
|
function Read_Form return Mal.T;
|
||||||
-- The recursive part of Read_Str.
|
-- The recursive part of Read_Str.
|
||||||
|
|
||||||
-- Helpers for Read_Form:
|
-- Helpers for Read_Form:
|
||||||
@ -58,124 +58,127 @@ package body Reader is
|
|||||||
|
|
||||||
-- Read_Atom has been merged into the same case/switch
|
-- Read_Atom has been merged into the same case/switch
|
||||||
-- statement, for clarity and efficiency.
|
-- statement, for clarity and efficiency.
|
||||||
procedure Read_List (Ending : in Character;
|
|
||||||
Constructor : in not null Mal.Builtin_Ptr)
|
function Read_List (Ending : in Character) return Natural with Inline;
|
||||||
with Inline;
|
-- Returns the index of the last elements in Buffer.
|
||||||
procedure Read_Quote (Symbol : in Symbols.Ptr) with Inline;
|
-- The elements have been stored in Buffer (B_Last .. result).
|
||||||
procedure Read_String with Inline;
|
|
||||||
procedure Read_With_Meta with Inline;
|
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline;
|
||||||
|
|
||||||
|
function Read_String return Mal.T with Inline;
|
||||||
|
|
||||||
|
function Read_With_Meta return Mal.T with Inline;
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
procedure Read_List (Ending : in Character;
|
function Read_List (Ending : in Character) return Natural is
|
||||||
Constructor : in not null Mal.Builtin_Ptr) is
|
|
||||||
Opening : constant Character := Source (I);
|
Opening : constant Character := Source (I);
|
||||||
B_First : constant Positive := B_Last;
|
Old : constant Natural := B_Last;
|
||||||
|
Result : Positive;
|
||||||
begin
|
begin
|
||||||
I := I + 1; -- Skip (, [ or {.
|
I := I + 1; -- Skip (, [ or {.
|
||||||
loop
|
loop
|
||||||
Skip_Ignored;
|
Skip_Ignored;
|
||||||
Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'");
|
Err.Check (I <= Source'Last, "unbalanced '" & Opening & "'");
|
||||||
exit when Source (I) = Ending;
|
exit when Source (I) = Ending;
|
||||||
Read_Form;
|
|
||||||
B_Last := B_Last + 1;
|
B_Last := B_Last + 1;
|
||||||
|
Buffer (B_Last) := Read_Form;
|
||||||
end loop;
|
end loop;
|
||||||
I := I + 1; -- Skip ), ] or }.
|
I := I + 1; -- Skip ), ] or }.
|
||||||
Buffer (B_First) := Constructor.all (Buffer (B_First .. B_Last - 1));
|
Result := B_Last;
|
||||||
B_Last := B_First;
|
B_Last := Old;
|
||||||
|
return Result;
|
||||||
end Read_List;
|
end Read_List;
|
||||||
|
|
||||||
procedure Read_Quote (Symbol : in Symbols.Ptr) is
|
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is
|
||||||
|
R : constant Mal.Sequence_Ptr := Sequences.Constructor (2);
|
||||||
begin
|
begin
|
||||||
Buffer (B_Last) := (Kind_Symbol, Symbol);
|
|
||||||
I := I + 1; -- Skip the initial ' or similar.
|
I := I + 1; -- Skip the initial ' or similar.
|
||||||
|
R.Replace_Element (1, (Kind_Symbol, Symbol));
|
||||||
Skip_Ignored;
|
Skip_Ignored;
|
||||||
Err.Check (I <= Source'Last, "Incomplete '" & Symbol.To_String & "'");
|
Err.Check (I <= Source'Last,
|
||||||
B_Last := B_Last + 1;
|
"Incomplete '" & Symbols.To_String (Symbol) & "'");
|
||||||
Read_Form;
|
R.Replace_Element (2, Read_Form);
|
||||||
B_Last := B_Last - 1;
|
return (Kind_List, R);
|
||||||
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 1));
|
|
||||||
end Read_Quote;
|
end Read_Quote;
|
||||||
|
|
||||||
procedure Read_Form is
|
function Read_Form return Mal.T is
|
||||||
-- After I has been increased, current token is be
|
-- After I has been increased, current token is be
|
||||||
-- Source (F .. I - 1).
|
-- Source (F .. I - 1).
|
||||||
F : Positive;
|
F : Positive;
|
||||||
|
R : Mal.T; -- The result of this function.
|
||||||
begin
|
begin
|
||||||
case Source (I) is
|
case Source (I) is
|
||||||
when ')' | ']' | '}' =>
|
when ')' | ']' | '}' =>
|
||||||
Err.Raise_With ("unbalanced '" & Source (I) & "'");
|
Err.Raise_With ("unbalanced '" & Source (I) & "'");
|
||||||
when '"' =>
|
when '"' =>
|
||||||
Read_String;
|
R := Read_String;
|
||||||
when ':' =>
|
when ':' =>
|
||||||
I := I + 1;
|
I := I + 1;
|
||||||
F := I;
|
F := I;
|
||||||
Skip_Symbol;
|
Skip_Symbol;
|
||||||
Buffer (B_Last) := (Kind_Keyword,
|
R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String
|
||||||
Ada.Strings.Unbounded.To_Unbounded_String
|
(Source (F .. I - 1)));
|
||||||
(Source (F .. I - 1)));
|
|
||||||
when '-' =>
|
when '-' =>
|
||||||
F := I;
|
F := I;
|
||||||
Skip_Digits;
|
Skip_Digits;
|
||||||
if F + 1 < I then
|
if F + 1 < I then
|
||||||
Buffer (B_Last) := (Kind_Number,
|
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
|
||||||
Integer'Value (Source (F .. I - 1)));
|
|
||||||
else
|
else
|
||||||
Skip_Symbol;
|
Skip_Symbol;
|
||||||
Buffer (B_Last) := (Kind_Symbol,
|
R := (Kind_Symbol,
|
||||||
Symbols.Constructor (Source (F .. I - 1)));
|
Symbols.Constructor (Source (F .. I - 1)));
|
||||||
end if;
|
end if;
|
||||||
when '~' =>
|
when '~' =>
|
||||||
if I < Source'Last and then Source (I + 1) = '@' then
|
if I < Source'Last and then Source (I + 1) = '@' then
|
||||||
I := I + 1;
|
I := I + 1;
|
||||||
Read_Quote (Symbols.Names.Splice_Unquote);
|
R := Read_Quote (Symbols.Names.Splice_Unquote);
|
||||||
else
|
else
|
||||||
Read_Quote (Symbols.Names.Unquote);
|
R := Read_Quote (Symbols.Names.Unquote);
|
||||||
end if;
|
end if;
|
||||||
when '0' .. '9' =>
|
when '0' .. '9' =>
|
||||||
F := I;
|
F := I;
|
||||||
Skip_Digits;
|
Skip_Digits;
|
||||||
Buffer (B_Last) := (Kind_Number,
|
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
|
||||||
Integer'Value (Source (F .. I - 1)));
|
|
||||||
when ''' =>
|
when ''' =>
|
||||||
Read_Quote (Symbols.Names.Quote);
|
R := Read_Quote (Symbols.Names.Quote);
|
||||||
when '`' =>
|
when '`' =>
|
||||||
Read_Quote (Symbols.Names.Quasiquote);
|
R := Read_Quote (Symbols.Names.Quasiquote);
|
||||||
when '@' =>
|
when '@' =>
|
||||||
Read_Quote (Symbols.Names.Deref);
|
R := Read_Quote (Symbols.Names.Deref);
|
||||||
when '^' =>
|
when '^' =>
|
||||||
Read_With_Meta;
|
R := Read_With_Meta;
|
||||||
when '(' =>
|
when '(' =>
|
||||||
Read_List (')', Sequences.List'Access);
|
R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')')));
|
||||||
when '[' =>
|
when '[' =>
|
||||||
Read_List (']', Sequences.Vector'Access);
|
R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']')));
|
||||||
when '{' =>
|
when '{' =>
|
||||||
Read_List ('}', Maps.Hash_Map'Access);
|
R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}')));
|
||||||
when others =>
|
when others =>
|
||||||
F := I;
|
F := I;
|
||||||
Skip_Symbol;
|
Skip_Symbol;
|
||||||
if Source (F .. I - 1) = "false" then
|
if Source (F .. I - 1) = "false" then
|
||||||
Buffer (B_Last) := (Kind_Boolean, False);
|
R := (Kind_Boolean, False);
|
||||||
elsif Source (F .. I - 1) = "nil" then
|
elsif Source (F .. I - 1) = "nil" then
|
||||||
Buffer (B_Last) := Mal.Nil;
|
R := Mal.Nil;
|
||||||
elsif Source (F .. I - 1) = "true" then
|
elsif Source (F .. I - 1) = "true" then
|
||||||
Buffer (B_Last) := (Kind_Boolean, True);
|
R := (Kind_Boolean, True);
|
||||||
else
|
else
|
||||||
Buffer (B_Last) := (Kind_Symbol,
|
R := (Kind_Symbol,
|
||||||
Symbols.Constructor (Source (F .. I - 1)));
|
Symbols.Constructor (Source (F .. I - 1)));
|
||||||
end if;
|
end if;
|
||||||
end case;
|
end case;
|
||||||
if Debug then
|
if Debug then
|
||||||
Ada.Text_IO.Put ("reader: ");
|
Ada.Text_IO.Put ("reader: ");
|
||||||
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Buffer
|
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (R));
|
||||||
(B_Last)));
|
|
||||||
end if;
|
end if;
|
||||||
|
return R;
|
||||||
end Read_Form;
|
end Read_Form;
|
||||||
|
|
||||||
procedure Read_String is
|
function Read_String return Mal.T is
|
||||||
use Ada.Strings.Unbounded;
|
use Ada.Strings.Unbounded;
|
||||||
|
Result : Unbounded_String;
|
||||||
begin
|
begin
|
||||||
Buffer (B_Last) := (Kind_String, Null_Unbounded_String);
|
|
||||||
loop
|
loop
|
||||||
I := I + 1;
|
I := I + 1;
|
||||||
Err.Check (I <= Source'Last, "unbalanced '""'");
|
Err.Check (I <= Source'Last, "unbalanced '""'");
|
||||||
@ -187,33 +190,31 @@ package body Reader is
|
|||||||
Err.Check (I <= Source'Last, "unbalanced '""'");
|
Err.Check (I <= Source'Last, "unbalanced '""'");
|
||||||
case Source (I) is
|
case Source (I) is
|
||||||
when '\' | '"' =>
|
when '\' | '"' =>
|
||||||
Append (Buffer (B_Last).S, Source (I));
|
Append (Result, Source (I));
|
||||||
when 'n' =>
|
when 'n' =>
|
||||||
Append (Buffer (B_Last).S, Ada.Characters.Latin_1.LF);
|
Append (Result, Ada.Characters.Latin_1.LF);
|
||||||
when others =>
|
when others =>
|
||||||
Append (Buffer (B_Last).S, Source (I - 1 .. I));
|
Append (Result, Source (I - 1 .. I));
|
||||||
end case;
|
end case;
|
||||||
when others =>
|
when others =>
|
||||||
Append (Buffer (B_Last).S, Source (I));
|
Append (Result, Source (I));
|
||||||
end case;
|
end case;
|
||||||
end loop;
|
end loop;
|
||||||
I := I + 1; -- Skip closing double quote.
|
I := I + 1; -- Skip closing double quote.
|
||||||
|
return (Kind_String, Result);
|
||||||
end Read_String;
|
end Read_String;
|
||||||
|
|
||||||
procedure Read_With_Meta is
|
function Read_With_Meta return Mal.T is
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (3);
|
||||||
begin
|
begin
|
||||||
I := I + 1; -- Skip the initial ^.
|
I := I + 1; -- Skip the initial ^.
|
||||||
for Argument in 1 .. 2 loop
|
List.all.Replace_Element (1, (Kind_Symbol, Symbols.Names.With_Meta));
|
||||||
|
for I in reverse 2 .. 3 loop
|
||||||
Skip_Ignored;
|
Skip_Ignored;
|
||||||
Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
|
Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
|
||||||
Read_Form;
|
List.all.Replace_Element (I, Read_Form);
|
||||||
B_Last := B_Last + 1;
|
|
||||||
end loop;
|
end loop;
|
||||||
-- Replace (metadata data) with (with-meta data metadata).
|
return (Kind_List, List);
|
||||||
B_Last := B_Last - 2;
|
|
||||||
Buffer (B_Last + 2) := Buffer (B_Last);
|
|
||||||
Buffer (B_Last) := (Kind_Symbol, Symbols.Names.With_Meta);
|
|
||||||
Buffer (B_Last) := Sequences.List (Buffer (B_Last .. B_Last + 2));
|
|
||||||
end Read_With_Meta;
|
end Read_With_Meta;
|
||||||
|
|
||||||
procedure Skip_Digits is
|
procedure Skip_Digits is
|
||||||
@ -259,7 +260,7 @@ package body Reader is
|
|||||||
Skip_Ignored;
|
Skip_Ignored;
|
||||||
exit when Source'Last < I;
|
exit when Source'Last < I;
|
||||||
B_Last := B_Last + 1;
|
B_Last := B_Last + 1;
|
||||||
Read_Form;
|
Buffer (B_Last) := Read_Form;
|
||||||
end loop;
|
end loop;
|
||||||
return Buffer (Buffer'First .. B_Last);
|
return Buffer (Buffer'First .. B_Last);
|
||||||
end Read_Str;
|
end Read_Str;
|
||||||
|
@ -1,15 +1,11 @@
|
|||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
|
||||||
with Types.Sequences;
|
|
||||||
with Types.Symbols;
|
with Types.Symbols;
|
||||||
|
|
||||||
procedure Step1_Read_Print is
|
procedure Step1_Read_Print is
|
||||||
@ -56,14 +52,14 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step1_Read_Print;
|
end Step1_Read_Print;
|
||||||
|
@ -4,12 +4,10 @@ with Ada.Strings.Hash;
|
|||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
with Types.Sequences;
|
with Types.Sequences;
|
||||||
@ -41,7 +39,6 @@ procedure Step2_Eval is
|
|||||||
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
||||||
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Map, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
@ -56,6 +53,7 @@ procedure Step2_Eval is
|
|||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -70,29 +68,40 @@ procedure Step2_Eval is
|
|||||||
return (Kind_Builtin, Envs.Element (C));
|
return (Kind_Builtin, Envs.Element (C));
|
||||||
end;
|
end;
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Eval (Ast.Sequence (1), Env);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
|
-- Ast is a non-empty list, First is its first element.
|
||||||
|
First := Eval (First, Env);
|
||||||
|
|
||||||
-- Apply phase.
|
-- Apply phase.
|
||||||
-- Ast is a non-empty list,
|
-- Ast is a non-empty list,
|
||||||
-- First is its non-special evaluated first element.
|
-- First is its evaluated first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
@ -147,14 +156,15 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step2_Eval;
|
end Step2_Eval;
|
||||||
|
@ -3,12 +3,10 @@ with Ada.Text_IO.Unbounded_IO;
|
|||||||
|
|
||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
with Types.Sequences;
|
with Types.Sequences;
|
||||||
@ -16,11 +14,7 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step3_Env is
|
procedure Step3_Env is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
|
|
||||||
@ -37,7 +31,6 @@ procedure Step3_Env is
|
|||||||
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
with function Ada_Operator (Left, Right : in Integer) return Integer;
|
||||||
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
@ -52,60 +45,67 @@ procedure Step3_Env is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
-- This curious syntax is useful for later steps.
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
New_Env : Envs.Ptr := Env.Copy_Pointer;
|
New_Env : Envs.Ptr;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
New_Env.Replace_With_Sub;
|
New_Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
New_Env.Set (Bindings (2 * I - 1).Symbol,
|
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), New_Env));
|
Eval (Bindings.all (2 * I), New_Env));
|
||||||
end loop;
|
end loop;
|
||||||
return Eval (Ast.Sequence (3), New_Env);
|
return Eval (Ast.Sequence.all (3), New_Env);
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
First := Eval (First, Env);
|
First := Eval (First, Env);
|
||||||
@ -120,10 +120,10 @@ procedure Step3_Env is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
@ -162,16 +162,18 @@ procedure Step3_Env is
|
|||||||
function Product is new Generic_Mal_Operator ("*");
|
function Product is new Generic_Mal_Operator ("*");
|
||||||
function Division is new Generic_Mal_Operator ("/");
|
function Division is new Generic_Mal_Operator ("/");
|
||||||
|
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
begin
|
begin
|
||||||
Repl.Set (Symbols.Constructor ("+"),
|
-- Add Core functions into the top environment.
|
||||||
(Kind_Builtin, Addition 'Unrestricted_Access));
|
Repl.all.Set (Symbols.Constructor ("+"),
|
||||||
Repl.Set (Symbols.Constructor ("-"),
|
(Kind_Builtin, Addition 'Unrestricted_Access));
|
||||||
(Kind_Builtin, Subtraction'Unrestricted_Access));
|
Repl.all.Set (Symbols.Constructor ("-"),
|
||||||
Repl.Set (Symbols.Constructor ("*"),
|
(Kind_Builtin, Subtraction'Unrestricted_Access));
|
||||||
(Kind_Builtin, Product 'Unrestricted_Access));
|
Repl.all.Set (Symbols.Constructor ("*"),
|
||||||
Repl.Set (Symbols.Constructor ("/"),
|
(Kind_Builtin, Product 'Unrestricted_Access));
|
||||||
(Kind_Builtin, Division 'Unrestricted_Access));
|
Repl.all.Set (Symbols.Constructor ("/"),
|
||||||
|
(Kind_Builtin, Division 'Unrestricted_Access));
|
||||||
|
-- Execute user commands.
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
Rep (Repl);
|
Rep (Repl);
|
||||||
@ -182,15 +184,16 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step3_Env;
|
end Step3_Env;
|
||||||
|
@ -5,11 +5,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -18,11 +17,7 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step4_If_Fn_Do is
|
procedure Step4_If_Fn_Do is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
@ -36,7 +31,6 @@ procedure Step4_If_Fn_Do is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -55,82 +49,90 @@ procedure Step4_If_Fn_Do is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
return Eval (Ast.Sequence (3), Env);
|
return Eval (Ast.Sequence.all (3), Env);
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
return Eval (Ast.Sequence (4), Env);
|
return Eval (Ast.Sequence.all (4), Env);
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
-- This curious syntax is useful for later steps.
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
New_Env : Envs.Ptr := Env.Copy_Pointer;
|
New_Env : Envs.Ptr;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
New_Env.Replace_With_Sub;
|
New_Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
New_Env.Set (Bindings (2 * I - 1).Symbol,
|
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), New_Env));
|
Eval (Bindings.all (2 * I), New_Env));
|
||||||
end loop;
|
end loop;
|
||||||
return Eval (Ast.Sequence (3), New_Env);
|
return Eval (Ast.Sequence.all (3), New_Env);
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
First := Eval (First, Env);
|
First := Eval (First, Env);
|
||||||
@ -145,21 +147,21 @@ procedure Step4_If_Fn_Do is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Fn.Apply (Args);
|
return First.Fn.all.Apply (Args);
|
||||||
end;
|
end;
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("first element must be a function");
|
Err.Raise_With ("first element must be a function");
|
||||||
@ -200,14 +202,15 @@ procedure Step4_If_Fn_Do is
|
|||||||
|
|
||||||
Startup : constant String
|
Startup : constant String
|
||||||
:= "(def! not (fn* (a) (if a false true)))";
|
:= "(def! not (fn* (a) (if a false true)))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
|
-- Execute user commands.
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
Rep (Repl);
|
Rep (Repl);
|
||||||
@ -218,15 +221,16 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step4_If_Fn_Do;
|
end Step4_If_Fn_Do;
|
||||||
|
@ -5,11 +5,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -18,11 +17,7 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step5_Tco is
|
procedure Step5_Tco is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
@ -36,7 +31,6 @@ procedure Step5_Tco is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -52,7 +46,7 @@ procedure Step5_Tco is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
<<Restart>>
|
<<Restart>>
|
||||||
@ -60,88 +54,97 @@ procedure Step5_Tco is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -160,24 +163,24 @@ procedure Step5_Tco is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when others =>
|
when others =>
|
||||||
@ -219,14 +222,15 @@ procedure Step5_Tco is
|
|||||||
|
|
||||||
Startup : constant String
|
Startup : constant String
|
||||||
:= "(def! not (fn* (a) (if a false true)))";
|
:= "(def! not (fn* (a) (if a false true)))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
|
-- Execute user commands.
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
Rep (Repl);
|
Rep (Repl);
|
||||||
@ -237,15 +241,16 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step5_Tco;
|
end Step5_Tco;
|
||||||
|
@ -7,11 +7,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -20,26 +19,24 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step6_File is
|
procedure Step6_File is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
|
package ACL renames Ada.Command_Line;
|
||||||
package ASU renames Ada.Strings.Unbounded;
|
package ASU renames Ada.Strings.Unbounded;
|
||||||
|
|
||||||
function Read return Mal.T_Array with Inline;
|
function Read return Mal.T_Array with Inline;
|
||||||
|
|
||||||
function Eval (Ast0 : in Mal.T;
|
function Eval (Ast0 : in Mal.T;
|
||||||
Env0 : in Envs.Ptr) return Mal.T;
|
Env0 : in Envs.Ptr) return Mal.T;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
-- The built-in variant needs to see the Repl variable.
|
||||||
|
|
||||||
procedure Print (Ast : in Mal.T) with Inline;
|
procedure Print (Ast : in Mal.T) with Inline;
|
||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -55,7 +52,7 @@ procedure Step6_File is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
<<Restart>>
|
<<Restart>>
|
||||||
@ -63,88 +60,97 @@ procedure Step6_File is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -163,24 +169,24 @@ procedure Step6_File is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when others =>
|
when others =>
|
||||||
@ -224,27 +230,37 @@ procedure Step6_File is
|
|||||||
:= "(def! not (fn* (a) (if a false true)))"
|
:= "(def! not (fn* (a) (if a false true)))"
|
||||||
& "(def! load-file (fn* (f)"
|
& "(def! load-file (fn* (f)"
|
||||||
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
begin
|
||||||
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
|
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||||
|
end Eval_Builtin;
|
||||||
|
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||||
|
Argv : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
|
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||||
|
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
-- Define ARGV from command line arguments.
|
-- Define ARGV from command line arguments.
|
||||||
declare
|
if Script then
|
||||||
use Ada.Command_Line;
|
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||||
Args : Mal.T_Array (2 .. Argument_Count);
|
for I in 2 .. ACL.Argument_Count loop
|
||||||
begin
|
Argv.all.Replace_Element
|
||||||
for I in Args'Range loop
|
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
|
||||||
end loop;
|
end loop;
|
||||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
else
|
||||||
end;
|
Argv := Sequences.Constructor (0);
|
||||||
-- Script?
|
end if;
|
||||||
if 0 < Ada.Command_Line.Argument_Count then
|
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
-- Execute user commands.
|
||||||
|
if Script then
|
||||||
|
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||||
else
|
else
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
@ -256,16 +272,17 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step6_File;
|
end Step6_File;
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
with Ada.Command_Line;
|
with Ada.Command_Line;
|
||||||
|
with Ada.Containers.Vectors;
|
||||||
with Ada.Environment_Variables;
|
with Ada.Environment_Variables;
|
||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
@ -7,11 +8,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step7_Quote is
|
procedure Step7_Quote is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
|
package ACL renames Ada.Command_Line;
|
||||||
package ASU renames Ada.Strings.Unbounded;
|
package ASU renames Ada.Strings.Unbounded;
|
||||||
|
|
||||||
function Read return Mal.T_Array with Inline;
|
function Read return Mal.T_Array with Inline;
|
||||||
|
|
||||||
function Eval (Ast0 : in Mal.T;
|
function Eval (Ast0 : in Mal.T;
|
||||||
Env0 : in Envs.Ptr) return Mal.T;
|
Env0 : in Envs.Ptr) return Mal.T;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
-- The built-in variant needs to see the Repl variable.
|
||||||
|
|
||||||
function Quasiquote (Ast : in Mal.T;
|
function Quasiquote (Ast : in Mal.T;
|
||||||
Env : in Envs.Ptr) return Mal.T;
|
Env : in Envs.Ptr) return Mal.T;
|
||||||
@ -46,7 +45,6 @@ procedure Step7_Quote is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -62,7 +60,7 @@ procedure Step7_Quote is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
<<Restart>>
|
<<Restart>>
|
||||||
@ -70,94 +68,103 @@ procedure Step7_Quote is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Quasiquote (Ast.Sequence (2), Env);
|
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||||
elsif First.Symbol = Symbols.Names.Quote then
|
elsif First.Symbol = Symbols.Names.Quote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Ast.Sequence (2);
|
return Ast.Sequence.all (2);
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -176,24 +183,24 @@ procedure Step7_Quote is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when others =>
|
when others =>
|
||||||
@ -225,46 +232,56 @@ procedure Step7_Quote is
|
|||||||
Env : in Envs.Ptr) return Mal.T
|
Env : in Envs.Ptr) return Mal.T
|
||||||
is
|
is
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||||
with Inline;
|
with Inline;
|
||||||
-- Handle vectors and lists not starting with unquote.
|
-- Handle vectors and lists not starting with unquote.
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||||
-- The final return concatenates these lists.
|
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||||
R : Mal.T_Array (1 .. List.Length);
|
Vector : Vectors.Vector; -- buffer for concatenation
|
||||||
|
Sequence : Mal.Sequence_Ptr;
|
||||||
|
Tmp : Mal.T;
|
||||||
begin
|
begin
|
||||||
for I in R'Range loop
|
for I in 1 .. List.Length loop
|
||||||
R (I) := List (I);
|
if List (I).Kind in Kind_List
|
||||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
and then 0 < List (I).Sequence.all.Length
|
||||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
and then List (I).Sequence.all (1)
|
||||||
Symbols.Names.Splice_Unquote)
|
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (R (I).Sequence.Length = 2,
|
Err.Check (List (I).Sequence.all.Length = 2,
|
||||||
"splice-unquote expects 1 parameter");
|
"splice-unquote expects 1 parameter");
|
||||||
R (I) := Eval (@.Sequence (2), Env);
|
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||||
Err.Check (R (I).Kind = Kind_List,
|
Err.Check (Tmp.Kind = Kind_List,
|
||||||
"splice_unquote expects a list");
|
"splice_unquote expects a list");
|
||||||
|
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||||
|
Vector.Append (Tmp.Sequence.all (I));
|
||||||
|
end loop;
|
||||||
else
|
else
|
||||||
R (I) := Sequences.List
|
Vector.Append (Quasiquote (List (I), Env));
|
||||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
return Sequences.Concat (R);
|
-- Now that we know the number of elements, convert to a list.
|
||||||
|
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||||
|
for I in 1 .. Natural (Vector.Length) loop
|
||||||
|
Sequence.Replace_Element (I, Vector (I));
|
||||||
|
end loop;
|
||||||
|
return (Kind_List, Sequence);
|
||||||
end Quasiquote_List;
|
end Quasiquote_List;
|
||||||
|
|
||||||
begin -- Quasiquote
|
begin -- Quasiquote
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
if 0 < Ast.Sequence.Length
|
if 0 < Ast.Sequence.all.Length
|
||||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||||
|
Symbols.Names.Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
else
|
else
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
end if;
|
end if;
|
||||||
when others =>
|
when others =>
|
||||||
return Ast;
|
return Ast;
|
||||||
@ -291,27 +308,37 @@ procedure Step7_Quote is
|
|||||||
:= "(def! not (fn* (a) (if a false true)))"
|
:= "(def! not (fn* (a) (if a false true)))"
|
||||||
& "(def! load-file (fn* (f)"
|
& "(def! load-file (fn* (f)"
|
||||||
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
begin
|
||||||
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
|
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||||
|
end Eval_Builtin;
|
||||||
|
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||||
|
Argv : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
|
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||||
|
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
-- Define ARGV from command line arguments.
|
-- Define ARGV from command line arguments.
|
||||||
declare
|
if Script then
|
||||||
use Ada.Command_Line;
|
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||||
Args : Mal.T_Array (2 .. Argument_Count);
|
for I in 2 .. ACL.Argument_Count loop
|
||||||
begin
|
Argv.all.Replace_Element
|
||||||
for I in Args'Range loop
|
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
|
||||||
end loop;
|
end loop;
|
||||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
else
|
||||||
end;
|
Argv := Sequences.Constructor (0);
|
||||||
-- Script?
|
end if;
|
||||||
if 0 < Ada.Command_Line.Argument_Count then
|
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
-- Execute user commands.
|
||||||
|
if Script then
|
||||||
|
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||||
else
|
else
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
@ -323,16 +350,17 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step7_Quote;
|
end Step7_Quote;
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
with Ada.Command_Line;
|
with Ada.Command_Line;
|
||||||
|
with Ada.Containers.Vectors;
|
||||||
with Ada.Environment_Variables;
|
with Ada.Environment_Variables;
|
||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
@ -7,11 +8,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step8_Macros is
|
procedure Step8_Macros is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
|
package ACL renames Ada.Command_Line;
|
||||||
package ASU renames Ada.Strings.Unbounded;
|
package ASU renames Ada.Strings.Unbounded;
|
||||||
|
|
||||||
function Read return Mal.T_Array with Inline;
|
function Read return Mal.T_Array with Inline;
|
||||||
|
|
||||||
function Eval (Ast0 : in Mal.T;
|
function Eval (Ast0 : in Mal.T;
|
||||||
Env0 : in Envs.Ptr) return Mal.T;
|
Env0 : in Envs.Ptr) return Mal.T;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
-- The built-in variant needs to see the Repl variable.
|
||||||
|
|
||||||
function Quasiquote (Ast : in Mal.T;
|
function Quasiquote (Ast : in Mal.T;
|
||||||
Env : in Envs.Ptr) return Mal.T;
|
Env : in Envs.Ptr) return Mal.T;
|
||||||
@ -46,7 +45,6 @@ procedure Step8_Macros is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -62,7 +60,7 @@ procedure Step8_Macros is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
Macroexpanding : Boolean := False;
|
Macroexpanding : Boolean := False;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
@ -71,111 +69,120 @@ procedure Step8_Macros is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
declare
|
declare
|
||||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||||
begin
|
begin
|
||||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||||
return R : constant Mal.T := F.Fn.New_Macro do
|
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
end;
|
end;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
Macroexpanding := True;
|
Macroexpanding := True;
|
||||||
Ast := Ast.Sequence (2);
|
Ast := Ast.Sequence.all (2);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Quasiquote (Ast.Sequence (2), Env);
|
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||||
elsif First.Symbol = Symbols.Names.Quote then
|
elsif First.Symbol = Symbols.Names.Quote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Ast.Sequence (2);
|
return Ast.Sequence.all (2);
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -194,43 +201,44 @@ procedure Step8_Macros is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when Kind_Macro =>
|
when Kind_Macro =>
|
||||||
declare
|
declare
|
||||||
Args : constant Mal.T_Array
|
Args : constant Mal.T_Array
|
||||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||||
begin
|
begin
|
||||||
if Macroexpanding then
|
if Macroexpanding then
|
||||||
-- Evaluate the macro with tail call optimization.
|
-- Evaluate the macro with tail call optimization.
|
||||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
Env := Envs.New_Env (Outer => Env,
|
||||||
Exprs => Args);
|
Binds => First.Fn.all.Params,
|
||||||
Ast := First.Fn.Ast;
|
Exprs => Args);
|
||||||
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
else
|
else
|
||||||
-- Evaluate the macro normally.
|
-- Evaluate the macro normally.
|
||||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
Ast := Eval (First.Fn.all.Ast,
|
||||||
(Outer => Env,
|
Envs.New_Env (Outer => Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args));
|
Exprs => Args));
|
||||||
-- Then evaluate the result with TCO.
|
-- Then evaluate the result with TCO.
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
@ -268,46 +276,56 @@ procedure Step8_Macros is
|
|||||||
Env : in Envs.Ptr) return Mal.T
|
Env : in Envs.Ptr) return Mal.T
|
||||||
is
|
is
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||||
with Inline;
|
with Inline;
|
||||||
-- Handle vectors and lists not starting with unquote.
|
-- Handle vectors and lists not starting with unquote.
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||||
-- The final return concatenates these lists.
|
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||||
R : Mal.T_Array (1 .. List.Length);
|
Vector : Vectors.Vector; -- buffer for concatenation
|
||||||
|
Sequence : Mal.Sequence_Ptr;
|
||||||
|
Tmp : Mal.T;
|
||||||
begin
|
begin
|
||||||
for I in R'Range loop
|
for I in 1 .. List.Length loop
|
||||||
R (I) := List (I);
|
if List (I).Kind in Kind_List
|
||||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
and then 0 < List (I).Sequence.all.Length
|
||||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
and then List (I).Sequence.all (1)
|
||||||
Symbols.Names.Splice_Unquote)
|
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (R (I).Sequence.Length = 2,
|
Err.Check (List (I).Sequence.all.Length = 2,
|
||||||
"splice-unquote expects 1 parameter");
|
"splice-unquote expects 1 parameter");
|
||||||
R (I) := Eval (@.Sequence (2), Env);
|
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||||
Err.Check (R (I).Kind = Kind_List,
|
Err.Check (Tmp.Kind = Kind_List,
|
||||||
"splice_unquote expects a list");
|
"splice_unquote expects a list");
|
||||||
|
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||||
|
Vector.Append (Tmp.Sequence.all (I));
|
||||||
|
end loop;
|
||||||
else
|
else
|
||||||
R (I) := Sequences.List
|
Vector.Append (Quasiquote (List (I), Env));
|
||||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
return Sequences.Concat (R);
|
-- Now that we know the number of elements, convert to a list.
|
||||||
|
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||||
|
for I in 1 .. Natural (Vector.Length) loop
|
||||||
|
Sequence.Replace_Element (I, Vector (I));
|
||||||
|
end loop;
|
||||||
|
return (Kind_List, Sequence);
|
||||||
end Quasiquote_List;
|
end Quasiquote_List;
|
||||||
|
|
||||||
begin -- Quasiquote
|
begin -- Quasiquote
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
if 0 < Ast.Sequence.Length
|
if 0 < Ast.Sequence.all.Length
|
||||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||||
|
Symbols.Names.Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
else
|
else
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
end if;
|
end if;
|
||||||
when others =>
|
when others =>
|
||||||
return Ast;
|
return Ast;
|
||||||
@ -345,27 +363,37 @@ procedure Step8_Macros is
|
|||||||
& " (if (= 1 (count xs)) (first xs)"
|
& " (if (= 1 (count xs)) (first xs)"
|
||||||
& " `(let* (or_FIXME ~(first xs))"
|
& " `(let* (or_FIXME ~(first xs))"
|
||||||
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
begin
|
||||||
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
|
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||||
|
end Eval_Builtin;
|
||||||
|
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||||
|
Argv : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
|
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||||
|
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
-- Define ARGV from command line arguments.
|
-- Define ARGV from command line arguments.
|
||||||
declare
|
if Script then
|
||||||
use Ada.Command_Line;
|
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||||
Args : Mal.T_Array (2 .. Argument_Count);
|
for I in 2 .. ACL.Argument_Count loop
|
||||||
begin
|
Argv.all.Replace_Element
|
||||||
for I in Args'Range loop
|
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
|
||||||
end loop;
|
end loop;
|
||||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
else
|
||||||
end;
|
Argv := Sequences.Constructor (0);
|
||||||
-- Script?
|
end if;
|
||||||
if 0 < Ada.Command_Line.Argument_Count then
|
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
-- Execute user commands.
|
||||||
|
if Script then
|
||||||
|
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||||
else
|
else
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
@ -377,16 +405,17 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step8_Macros;
|
end Step8_Macros;
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
with Ada.Command_Line;
|
with Ada.Command_Line;
|
||||||
|
with Ada.Containers.Vectors;
|
||||||
with Ada.Environment_Variables;
|
with Ada.Environment_Variables;
|
||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
@ -7,11 +8,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
with Types.Maps;
|
with Types.Maps;
|
||||||
@ -20,20 +20,19 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure Step9_Try is
|
procedure Step9_Try is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
|
package ACL renames Ada.Command_Line;
|
||||||
package ASU renames Ada.Strings.Unbounded;
|
package ASU renames Ada.Strings.Unbounded;
|
||||||
|
|
||||||
function Read return Mal.T_Array with Inline;
|
function Read return Mal.T_Array with Inline;
|
||||||
|
|
||||||
function Eval (Ast0 : in Mal.T;
|
function Eval (Ast0 : in Mal.T;
|
||||||
Env0 : in Envs.Ptr) return Mal.T;
|
Env0 : in Envs.Ptr) return Mal.T;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
-- The built-in variant needs to see the Repl variable.
|
||||||
|
|
||||||
function Quasiquote (Ast : in Mal.T;
|
function Quasiquote (Ast : in Mal.T;
|
||||||
Env : in Envs.Ptr) return Mal.T;
|
Env : in Envs.Ptr) return Mal.T;
|
||||||
@ -46,7 +45,6 @@ procedure Step9_Try is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -62,7 +60,7 @@ procedure Step9_Try is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
Macroexpanding : Boolean := False;
|
Macroexpanding : Boolean := False;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
@ -71,137 +69,149 @@ procedure Step9_Try is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
declare
|
declare
|
||||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||||
begin
|
begin
|
||||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||||
return R : constant Mal.T := F.Fn.New_Macro do
|
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
end;
|
end;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
Macroexpanding := True;
|
Macroexpanding := True;
|
||||||
Ast := Ast.Sequence (2);
|
Ast := Ast.Sequence.all (2);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Quasiquote (Ast.Sequence (2), Env);
|
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||||
elsif First.Symbol = Symbols.Names.Quote then
|
elsif First.Symbol = Symbols.Names.Quote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Ast.Sequence (2);
|
return Ast.Sequence.all (2);
|
||||||
elsif First.Symbol = Symbols.Names.Try then
|
elsif First.Symbol = Symbols.Names.Try then
|
||||||
if Ast.Sequence.Length = 2 then
|
if Ast.Sequence.all.Length = 2 then
|
||||||
Ast := Ast.Sequence (2);
|
Ast := Ast.Sequence.all (2);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3,
|
||||||
Err.Check (Ast.Sequence (3).Kind = Kind_List,
|
"expected 1 or 2 parameters");
|
||||||
|
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
|
||||||
"parameter 2 must be a list");
|
"parameter 2 must be a list");
|
||||||
declare
|
declare
|
||||||
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
|
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
|
Err.Check (A3.all.Length = 3,
|
||||||
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
|
"length of parameter 2 must be 3");
|
||||||
|
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||||
"parameter 3 must start with 'catch*'");
|
"parameter 3 must start with 'catch*'");
|
||||||
Err.Check (A3 (2).Kind = Kind_Symbol,
|
Err.Check (A3.all (2).Kind = Kind_Symbol,
|
||||||
"a symbol must follow catch*");
|
"a symbol must follow catch*");
|
||||||
begin
|
begin
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
exception
|
exception
|
||||||
when Err.Error =>
|
when Err.Error =>
|
||||||
Env.Replace_With_Sub;
|
null;
|
||||||
Env.Set (A3 (2).Symbol, Err.Data);
|
|
||||||
Ast := A3 (3);
|
|
||||||
goto Restart;
|
|
||||||
end;
|
end;
|
||||||
|
Env := Envs.New_Env (Outer => Env);
|
||||||
|
Env.all.Set (A3.all (2).Symbol, Err.Data);
|
||||||
|
Ast := A3.all (3);
|
||||||
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -220,43 +230,44 @@ procedure Step9_Try is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when Kind_Macro =>
|
when Kind_Macro =>
|
||||||
declare
|
declare
|
||||||
Args : constant Mal.T_Array
|
Args : constant Mal.T_Array
|
||||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||||
begin
|
begin
|
||||||
if Macroexpanding then
|
if Macroexpanding then
|
||||||
-- Evaluate the macro with tail call optimization.
|
-- Evaluate the macro with tail call optimization.
|
||||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
Env := Envs.New_Env (Outer => Env,
|
||||||
Exprs => Args);
|
Binds => First.Fn.all.Params,
|
||||||
Ast := First.Fn.Ast;
|
Exprs => Args);
|
||||||
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
else
|
else
|
||||||
-- Evaluate the macro normally.
|
-- Evaluate the macro normally.
|
||||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
Ast := Eval (First.Fn.all.Ast,
|
||||||
(Outer => Env,
|
Envs.New_Env (Outer => Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args));
|
Exprs => Args));
|
||||||
-- Then evaluate the result with TCO.
|
-- Then evaluate the result with TCO.
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
@ -294,46 +305,56 @@ procedure Step9_Try is
|
|||||||
Env : in Envs.Ptr) return Mal.T
|
Env : in Envs.Ptr) return Mal.T
|
||||||
is
|
is
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||||
with Inline;
|
with Inline;
|
||||||
-- Handle vectors and lists not starting with unquote.
|
-- Handle vectors and lists not starting with unquote.
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||||
-- The final return concatenates these lists.
|
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||||
R : Mal.T_Array (1 .. List.Length);
|
Vector : Vectors.Vector; -- buffer for concatenation
|
||||||
|
Sequence : Mal.Sequence_Ptr;
|
||||||
|
Tmp : Mal.T;
|
||||||
begin
|
begin
|
||||||
for I in R'Range loop
|
for I in 1 .. List.Length loop
|
||||||
R (I) := List (I);
|
if List (I).Kind in Kind_List
|
||||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
and then 0 < List (I).Sequence.all.Length
|
||||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
and then List (I).Sequence.all (1)
|
||||||
Symbols.Names.Splice_Unquote)
|
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (R (I).Sequence.Length = 2,
|
Err.Check (List (I).Sequence.all.Length = 2,
|
||||||
"splice-unquote expects 1 parameter");
|
"splice-unquote expects 1 parameter");
|
||||||
R (I) := Eval (@.Sequence (2), Env);
|
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||||
Err.Check (R (I).Kind = Kind_List,
|
Err.Check (Tmp.Kind = Kind_List,
|
||||||
"splice_unquote expects a list");
|
"splice_unquote expects a list");
|
||||||
|
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||||
|
Vector.Append (Tmp.Sequence.all (I));
|
||||||
|
end loop;
|
||||||
else
|
else
|
||||||
R (I) := Sequences.List
|
Vector.Append (Quasiquote (List (I), Env));
|
||||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
return Sequences.Concat (R);
|
-- Now that we know the number of elements, convert to a list.
|
||||||
|
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||||
|
for I in 1 .. Natural (Vector.Length) loop
|
||||||
|
Sequence.Replace_Element (I, Vector (I));
|
||||||
|
end loop;
|
||||||
|
return (Kind_List, Sequence);
|
||||||
end Quasiquote_List;
|
end Quasiquote_List;
|
||||||
|
|
||||||
begin -- Quasiquote
|
begin -- Quasiquote
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
if 0 < Ast.Sequence.Length
|
if 0 < Ast.Sequence.all.Length
|
||||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||||
|
Symbols.Names.Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
else
|
else
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
end if;
|
end if;
|
||||||
when others =>
|
when others =>
|
||||||
return Ast;
|
return Ast;
|
||||||
@ -371,27 +392,37 @@ procedure Step9_Try is
|
|||||||
& " (if (= 1 (count xs)) (first xs)"
|
& " (if (= 1 (count xs)) (first xs)"
|
||||||
& " `(let* (or_FIXME ~(first xs))"
|
& " `(let* (or_FIXME ~(first xs))"
|
||||||
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
begin
|
||||||
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
|
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||||
|
end Eval_Builtin;
|
||||||
|
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||||
|
Argv : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
|
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||||
|
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
-- Define ARGV from command line arguments.
|
-- Define ARGV from command line arguments.
|
||||||
declare
|
if Script then
|
||||||
use Ada.Command_Line;
|
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||||
Args : Mal.T_Array (2 .. Argument_Count);
|
for I in 2 .. ACL.Argument_Count loop
|
||||||
begin
|
Argv.all.Replace_Element
|
||||||
for I in Args'Range loop
|
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
|
||||||
end loop;
|
end loop;
|
||||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
else
|
||||||
end;
|
Argv := Sequences.Constructor (0);
|
||||||
-- Script?
|
end if;
|
||||||
if 0 < Ada.Command_Line.Argument_Count then
|
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
-- Execute user commands.
|
||||||
|
if Script then
|
||||||
|
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||||
else
|
else
|
||||||
loop
|
loop
|
||||||
begin
|
begin
|
||||||
@ -403,16 +434,17 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end Step9_Try;
|
end Step9_Try;
|
||||||
|
@ -1,4 +1,5 @@
|
|||||||
with Ada.Command_Line;
|
with Ada.Command_Line;
|
||||||
|
with Ada.Containers.Vectors;
|
||||||
with Ada.Environment_Variables;
|
with Ada.Environment_Variables;
|
||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
with Ada.Text_IO.Unbounded_IO;
|
with Ada.Text_IO.Unbounded_IO;
|
||||||
@ -7,10 +8,10 @@ with Core;
|
|||||||
with Envs;
|
with Envs;
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
|
with Garbage_Collected;
|
||||||
with Printer;
|
with Printer;
|
||||||
with Reader;
|
with Reader;
|
||||||
with Readline;
|
with Readline;
|
||||||
with Types.Atoms;
|
|
||||||
with Types.Builtins;
|
with Types.Builtins;
|
||||||
with Types.Fns;
|
with Types.Fns;
|
||||||
with Types.Mal;
|
with Types.Mal;
|
||||||
@ -20,20 +21,19 @@ with Types.Symbols.Names;
|
|||||||
|
|
||||||
procedure StepA_Mal is
|
procedure StepA_Mal is
|
||||||
|
|
||||||
Dbgenv1 : constant Boolean := Ada.Environment_Variables.Exists ("dbgenv1");
|
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
|
||||||
Dbgenv0 : constant Boolean
|
|
||||||
:= Dbgenv1 or Ada.Environment_Variables.Exists ("dbgenv0");
|
|
||||||
Dbgeval : constant Boolean
|
|
||||||
:= Dbgenv0 or Ada.Environment_Variables.Exists ("dbgeval");
|
|
||||||
|
|
||||||
use Types;
|
use Types;
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
|
package ACL renames Ada.Command_Line;
|
||||||
package ASU renames Ada.Strings.Unbounded;
|
package ASU renames Ada.Strings.Unbounded;
|
||||||
|
|
||||||
function Read return Mal.T_Array with Inline;
|
function Read return Mal.T_Array with Inline;
|
||||||
|
|
||||||
function Eval (Ast0 : in Mal.T;
|
function Eval (Ast0 : in Mal.T;
|
||||||
Env0 : in Envs.Ptr) return Mal.T;
|
Env0 : in Envs.Ptr) return Mal.T;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
-- The built-in variant needs to see the Repl variable.
|
||||||
|
|
||||||
function Quasiquote (Ast : in Mal.T;
|
function Quasiquote (Ast : in Mal.T;
|
||||||
Env : in Envs.Ptr) return Mal.T;
|
Env : in Envs.Ptr) return Mal.T;
|
||||||
@ -46,7 +46,6 @@ procedure StepA_Mal is
|
|||||||
|
|
||||||
procedure Rep (Env : in Envs.Ptr) with Inline;
|
procedure Rep (Env : in Envs.Ptr) with Inline;
|
||||||
|
|
||||||
function Eval_Seq_Elts is new Sequences.Generic_Eval (Envs.Ptr, Eval);
|
|
||||||
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
|
||||||
|
|
||||||
procedure Exec (Script : in String;
|
procedure Exec (Script : in String;
|
||||||
@ -62,7 +61,7 @@ procedure StepA_Mal is
|
|||||||
-- Use local variables, that can be rewritten when tail call
|
-- Use local variables, that can be rewritten when tail call
|
||||||
-- optimization goes to <<Restart>>.
|
-- optimization goes to <<Restart>>.
|
||||||
Ast : Mal.T := Ast0;
|
Ast : Mal.T := Ast0;
|
||||||
Env : Envs.Ptr := Env0.Copy_Pointer;
|
Env : Envs.Ptr := Env0;
|
||||||
Macroexpanding : Boolean := False;
|
Macroexpanding : Boolean := False;
|
||||||
First : Mal.T;
|
First : Mal.T;
|
||||||
begin
|
begin
|
||||||
@ -71,137 +70,149 @@ procedure StepA_Mal is
|
|||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
Ada.Text_IO.Put ("EVAL: ");
|
Ada.Text_IO.Put ("EVAL: ");
|
||||||
Print (Ast);
|
Print (Ast);
|
||||||
if Dbgenv0 then
|
Envs.Dump_Stack (Env.all);
|
||||||
Envs.Dump_Stack (Long => Dbgenv1);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
return Ast;
|
return Ast;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
return Env.Get (Ast.Symbol);
|
return Env.all.Get (Ast.Symbol);
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
return Eval_Map_Elts (Ast.Map, Env);
|
return Eval_Map_Elts (Ast.Map.all, Env);
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
return (Kind_Vector, Eval_Seq_Elts (Ast.Sequence, Env));
|
declare
|
||||||
|
Len : constant Natural := Ast.Sequence.all.Length;
|
||||||
|
List : constant Mal.Sequence_Ptr := Sequences.Constructor (Len);
|
||||||
|
begin
|
||||||
|
for I in 1 .. Len loop
|
||||||
|
List.all.Replace_Element (I, Eval (Ast.Sequence.all (I), Env));
|
||||||
|
end loop;
|
||||||
|
return (Kind_Vector, List);
|
||||||
|
end;
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
null;
|
null;
|
||||||
end case;
|
end case;
|
||||||
|
|
||||||
-- Ast is a list.
|
-- Ast is a list.
|
||||||
if Ast.Sequence.Length = 0 then
|
if Ast.Sequence.all.Length = 0 then
|
||||||
return Ast;
|
return Ast;
|
||||||
end if;
|
end if;
|
||||||
First := Ast.Sequence (1);
|
First := Ast.Sequence.all (1);
|
||||||
|
|
||||||
-- Special forms
|
-- Special forms
|
||||||
-- Ast is a non-empty list, First is its first element.
|
-- Ast is a non-empty list, First is its first element.
|
||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
if First.Symbol = Symbols.Names.Def then
|
if First.Symbol = Symbols.Names.Def then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
return R : constant Mal.T := Eval (Ast.Sequence (3), Env) do
|
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
elsif First.Symbol = Symbols.Names.Defmacro then
|
elsif First.Symbol = Symbols.Names.Defmacro then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind = Kind_Symbol,
|
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
|
||||||
"parameter 1 must be a symbol");
|
"parameter 1 must be a symbol");
|
||||||
declare
|
declare
|
||||||
F : constant Mal.T := Eval (Ast.Sequence (3), Env);
|
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
|
||||||
begin
|
begin
|
||||||
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
|
||||||
return R : constant Mal.T := F.Fn.New_Macro do
|
return R : constant Mal.T := F.Fn.all.New_Macro do
|
||||||
Env.Set (Ast.Sequence (2).Symbol, R);
|
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
|
||||||
end return;
|
end return;
|
||||||
end;
|
end;
|
||||||
-- do is a built-in function, shortening this test cascade.
|
-- do is a built-in function, shortening this test cascade.
|
||||||
elsif First.Symbol = Symbols.Names.Fn then
|
elsif First.Symbol = Symbols.Names.Fn then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
return Fns.New_Function (Params => Ast.Sequence (2).Sequence,
|
return Fns.New_Function
|
||||||
Ast => Ast.Sequence (3),
|
(Params => Ast.Sequence.all (2).Sequence.all,
|
||||||
Env => Env.New_Closure);
|
Ast => Ast.Sequence.all (3),
|
||||||
|
Env => Env);
|
||||||
elsif First.Symbol = Symbols.Names.Mal_If then
|
elsif First.Symbol = Symbols.Names.Mal_If then
|
||||||
Err.Check (Ast.Sequence.Length in 3 .. 4,
|
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
|
||||||
"expected 2 or 3 parameters");
|
"expected 2 or 3 parameters");
|
||||||
declare
|
declare
|
||||||
Test : constant Mal.T := Eval (Ast.Sequence (2), Env);
|
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
|
||||||
begin
|
begin
|
||||||
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif Ast.Sequence.Length = 3 then
|
elsif Ast.Sequence.all.Length = 3 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
else
|
else
|
||||||
Ast := Ast.Sequence (4);
|
Ast := Ast.Sequence.all (4);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Let then
|
elsif First.Symbol = Symbols.Names.Let then
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
|
||||||
Err.Check (Ast.Sequence (2).Kind in Kind_Sequence,
|
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
|
||||||
"parameter 1 must be a sequence");
|
"parameter 1 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Bindings : constant Sequences.Ptr := Ast.Sequence (2).Sequence;
|
Bindings : constant Mal.Sequence_Ptr
|
||||||
|
:= Ast.Sequence.all (2).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (Bindings.Length mod 2 = 0,
|
Err.Check (Bindings.all.Length mod 2 = 0,
|
||||||
"parameter 1 must have an even length");
|
"parameter 1 must have an even length");
|
||||||
Env.Replace_With_Sub;
|
Env := Envs.New_Env (Outer => Env);
|
||||||
for I in 1 .. Bindings.Length / 2 loop
|
for I in 1 .. Bindings.all.Length / 2 loop
|
||||||
Err.Check (Bindings (2 * I - 1).Kind = Kind_Symbol,
|
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
|
||||||
"binding keys must be symbols");
|
"binding keys must be symbols");
|
||||||
Env.Set (Bindings (2 * I - 1).Symbol,
|
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
|
||||||
Eval (Bindings (2 * I), Env));
|
Eval (Bindings.all (2 * I), Env));
|
||||||
end loop;
|
end loop;
|
||||||
Ast := Ast.Sequence (3);
|
Ast := Ast.Sequence.all (3);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
elsif First.Symbol = Symbols.Names.Macroexpand then
|
elsif First.Symbol = Symbols.Names.Macroexpand then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
Macroexpanding := True;
|
Macroexpanding := True;
|
||||||
Ast := Ast.Sequence (2);
|
Ast := Ast.Sequence.all (2);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
elsif First.Symbol = Symbols.Names.Quasiquote then
|
elsif First.Symbol = Symbols.Names.Quasiquote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Quasiquote (Ast.Sequence (2), Env);
|
return Quasiquote (Ast.Sequence.all (2), Env);
|
||||||
elsif First.Symbol = Symbols.Names.Quote then
|
elsif First.Symbol = Symbols.Names.Quote then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Ast.Sequence (2);
|
return Ast.Sequence.all (2);
|
||||||
elsif First.Symbol = Symbols.Names.Try then
|
elsif First.Symbol = Symbols.Names.Try then
|
||||||
if Ast.Sequence.Length = 2 then
|
if Ast.Sequence.all.Length = 2 then
|
||||||
Ast := Ast.Sequence (2);
|
Ast := Ast.Sequence.all (2);
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
Err.Check (Ast.Sequence.Length = 3, "expected 1 or 2 parameters");
|
Err.Check (Ast.Sequence.all.Length = 3,
|
||||||
Err.Check (Ast.Sequence (3).Kind = Kind_List,
|
"expected 1 or 2 parameters");
|
||||||
|
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
|
||||||
"parameter 2 must be a list");
|
"parameter 2 must be a list");
|
||||||
declare
|
declare
|
||||||
A3 : constant Sequences.Ptr := Ast.Sequence (3).Sequence;
|
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
|
||||||
begin
|
begin
|
||||||
Err.Check (A3.Length = 3, "length of parameter 2 must be 3");
|
Err.Check (A3.all.Length = 3,
|
||||||
Err.Check (A3 (1) = (Kind_Symbol, Symbols.Names.Catch),
|
"length of parameter 2 must be 3");
|
||||||
|
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
|
||||||
"parameter 3 must start with 'catch*'");
|
"parameter 3 must start with 'catch*'");
|
||||||
Err.Check (A3 (2).Kind = Kind_Symbol,
|
Err.Check (A3.all (2).Kind = Kind_Symbol,
|
||||||
"a symbol must follow catch*");
|
"a symbol must follow catch*");
|
||||||
begin
|
begin
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
exception
|
exception
|
||||||
when Err.Error =>
|
when Err.Error =>
|
||||||
Env.Replace_With_Sub;
|
null;
|
||||||
Env.Set (A3 (2).Symbol, Err.Data);
|
|
||||||
Ast := A3 (3);
|
|
||||||
goto Restart;
|
|
||||||
end;
|
end;
|
||||||
|
Env := Envs.New_Env (Outer => Env);
|
||||||
|
Env.all.Set (A3.all (2).Symbol, Err.Data);
|
||||||
|
Ast := A3.all (3);
|
||||||
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
else
|
else
|
||||||
-- Equivalent to First := Eval (First, Env)
|
-- Equivalent to First := Eval (First, Env)
|
||||||
-- except that we already know enough to spare a recursive call.
|
-- except that we already know enough to spare a recursive call.
|
||||||
First := Env.Get (First.Symbol);
|
First := Env.all.Get (First.Symbol);
|
||||||
end if;
|
end if;
|
||||||
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
|
||||||
| Kind_Macro | Kind_Function =>
|
| Kind_Macro | Kind_Function =>
|
||||||
@ -220,52 +231,53 @@ procedure StepA_Mal is
|
|||||||
case First.Kind is
|
case First.Kind is
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin.all (Args);
|
return First.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
return First.Builtin_With_Meta.Builtin.all (Args);
|
return First.Builtin_With_Meta.all.Builtin.all (Args);
|
||||||
end;
|
end;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
declare
|
declare
|
||||||
Args : Mal.T_Array (2 .. Ast.Sequence.Length);
|
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
|
||||||
begin
|
begin
|
||||||
for I in Args'Range loop
|
for I in Args'Range loop
|
||||||
Args (I) := Eval (Ast.Sequence (I), Env);
|
Args (I) := Eval (Ast.Sequence.all (I), Env);
|
||||||
end loop;
|
end loop;
|
||||||
Env.Replace_With_Sub (Outer => First.Fn.Env,
|
Env := Envs.New_Env (Outer => First.Fn.all.Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args);
|
Exprs => Args);
|
||||||
Ast := First.Fn.Ast;
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end;
|
end;
|
||||||
when Kind_Macro =>
|
when Kind_Macro =>
|
||||||
declare
|
declare
|
||||||
Args : constant Mal.T_Array
|
Args : constant Mal.T_Array
|
||||||
:= Ast.Sequence.Tail (Ast.Sequence.Length - 1);
|
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
|
||||||
begin
|
begin
|
||||||
if Macroexpanding then
|
if Macroexpanding then
|
||||||
-- Evaluate the macro with tail call optimization.
|
-- Evaluate the macro with tail call optimization.
|
||||||
Env.Replace_With_Sub (Binds => First.Fn.Params,
|
Env := Envs.New_Env (Outer => Env,
|
||||||
Exprs => Args);
|
Binds => First.Fn.all.Params,
|
||||||
Ast := First.Fn.Ast;
|
Exprs => Args);
|
||||||
|
Ast := First.Fn.all.Ast;
|
||||||
goto Restart;
|
goto Restart;
|
||||||
else
|
else
|
||||||
-- Evaluate the macro normally.
|
-- Evaluate the macro normally.
|
||||||
Ast := Eval (First.Fn.Ast, Envs.Sub
|
Ast := Eval (First.Fn.all.Ast,
|
||||||
(Outer => Env,
|
Envs.New_Env (Outer => Env,
|
||||||
Binds => First.Fn.Params,
|
Binds => First.Fn.all.Params,
|
||||||
Exprs => Args));
|
Exprs => Args));
|
||||||
-- Then evaluate the result with TCO.
|
-- Then evaluate the result with TCO.
|
||||||
goto Restart;
|
goto Restart;
|
||||||
end if;
|
end if;
|
||||||
@ -303,46 +315,56 @@ procedure StepA_Mal is
|
|||||||
Env : in Envs.Ptr) return Mal.T
|
Env : in Envs.Ptr) return Mal.T
|
||||||
is
|
is
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
|
||||||
with Inline;
|
with Inline;
|
||||||
-- Handle vectors and lists not starting with unquote.
|
-- Handle vectors and lists not starting with unquote.
|
||||||
|
|
||||||
function Quasiquote_List (List : in Sequences.Ptr) return Mal.T is
|
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
|
||||||
-- The final return concatenates these lists.
|
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
|
||||||
R : Mal.T_Array (1 .. List.Length);
|
Vector : Vectors.Vector; -- buffer for concatenation
|
||||||
|
Sequence : Mal.Sequence_Ptr;
|
||||||
|
Tmp : Mal.T;
|
||||||
begin
|
begin
|
||||||
for I in R'Range loop
|
for I in 1 .. List.Length loop
|
||||||
R (I) := List (I);
|
if List (I).Kind in Kind_List
|
||||||
if R (I).Kind in Kind_List and then 0 < R (I).Sequence.Length
|
and then 0 < List (I).Sequence.all.Length
|
||||||
and then R (I).Sequence (1) = (Kind_Symbol,
|
and then List (I).Sequence.all (1)
|
||||||
Symbols.Names.Splice_Unquote)
|
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (R (I).Sequence.Length = 2,
|
Err.Check (List (I).Sequence.all.Length = 2,
|
||||||
"splice-unquote expects 1 parameter");
|
"splice-unquote expects 1 parameter");
|
||||||
R (I) := Eval (@.Sequence (2), Env);
|
Tmp := Eval (List (I).Sequence.all (2), Env);
|
||||||
Err.Check (R (I).Kind = Kind_List,
|
Err.Check (Tmp.Kind = Kind_List,
|
||||||
"splice_unquote expects a list");
|
"splice_unquote expects a list");
|
||||||
|
for I in 1 .. Tmp.Sequence.all.Length loop
|
||||||
|
Vector.Append (Tmp.Sequence.all (I));
|
||||||
|
end loop;
|
||||||
else
|
else
|
||||||
R (I) := Sequences.List
|
Vector.Append (Quasiquote (List (I), Env));
|
||||||
(Mal.T_Array'(1 => Quasiquote (@, Env)));
|
|
||||||
end if;
|
end if;
|
||||||
end loop;
|
end loop;
|
||||||
return Sequences.Concat (R);
|
-- Now that we know the number of elements, convert to a list.
|
||||||
|
Sequence := Sequences.Constructor (Natural (Vector.Length));
|
||||||
|
for I in 1 .. Natural (Vector.Length) loop
|
||||||
|
Sequence.Replace_Element (I, Vector (I));
|
||||||
|
end loop;
|
||||||
|
return (Kind_List, Sequence);
|
||||||
end Quasiquote_List;
|
end Quasiquote_List;
|
||||||
|
|
||||||
begin -- Quasiquote
|
begin -- Quasiquote
|
||||||
case Ast.Kind is
|
case Ast.Kind is
|
||||||
when Kind_Vector =>
|
when Kind_Vector =>
|
||||||
-- When the test is updated, replace Kind_List with Kind_Vector.
|
-- When the test is updated, replace Kind_List with Kind_Vector.
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
when Kind_List =>
|
when Kind_List =>
|
||||||
if 0 < Ast.Sequence.Length
|
if 0 < Ast.Sequence.all.Length
|
||||||
and then Ast.Sequence (1) = (Kind_Symbol, Symbols.Names.Unquote)
|
and then Ast.Sequence.all (1) = (Kind_Symbol,
|
||||||
|
Symbols.Names.Unquote)
|
||||||
then
|
then
|
||||||
Err.Check (Ast.Sequence.Length = 2, "expected 1 parameter");
|
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
|
||||||
return Eval (Ast.Sequence (2), Env);
|
return Eval (Ast.Sequence.all (2), Env);
|
||||||
else
|
else
|
||||||
return Quasiquote_List (Ast.Sequence);
|
return Quasiquote_List (Ast.Sequence.all);
|
||||||
end if;
|
end if;
|
||||||
when others =>
|
when others =>
|
||||||
return Ast;
|
return Ast;
|
||||||
@ -385,27 +407,37 @@ procedure StepA_Mal is
|
|||||||
& " `(let* (~condvar ~(first xs))"
|
& " `(let* (~condvar ~(first xs))"
|
||||||
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
|
||||||
& "(def! *host-language* ""ada.2"")";
|
& "(def! *host-language* ""ada.2"")";
|
||||||
Repl : Envs.Ptr renames Envs.Repl;
|
Repl : constant Envs.Ptr := Envs.New_Env;
|
||||||
|
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
begin
|
||||||
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
|
return Eval_Cb.Cb.all (Args (Args'First), Repl);
|
||||||
|
end Eval_Builtin;
|
||||||
|
Script : constant Boolean := 0 < ACL.Argument_Count;
|
||||||
|
Argv : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Show the Eval function to other packages.
|
-- Show the Eval function to other packages.
|
||||||
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
Eval_Cb.Cb := Eval'Unrestricted_Access;
|
||||||
-- Add Core functions into the top environment.
|
-- Add Core functions into the top environment.
|
||||||
Core.NS_Add_To_Repl;
|
Core.NS_Add_To_Repl (Repl);
|
||||||
|
Repl.all.Set (Symbols.Constructor ("eval"),
|
||||||
|
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
|
||||||
-- Native startup procedure.
|
-- Native startup procedure.
|
||||||
Exec (Startup, Repl);
|
Exec (Startup, Repl);
|
||||||
-- Define ARGV from command line arguments.
|
-- Define ARGV from command line arguments.
|
||||||
declare
|
if Script then
|
||||||
use Ada.Command_Line;
|
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
|
||||||
Args : Mal.T_Array (2 .. Argument_Count);
|
for I in 2 .. ACL.Argument_Count loop
|
||||||
begin
|
Argv.all.Replace_Element
|
||||||
for I in Args'Range loop
|
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
|
||||||
Args (I) := (Kind_String, ASU.To_Unbounded_String (Argument (I)));
|
|
||||||
end loop;
|
end loop;
|
||||||
Repl.Set (Symbols.Constructor ("*ARGV*"), Sequences.List (Args));
|
else
|
||||||
end;
|
Argv := Sequences.Constructor (0);
|
||||||
-- Script?
|
end if;
|
||||||
if 0 < Ada.Command_Line.Argument_Count then
|
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
|
||||||
Exec ("(load-file """ & Ada.Command_Line.Argument (1) & """)", Repl);
|
-- Execute user commands.
|
||||||
|
if Script then
|
||||||
|
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
|
||||||
else
|
else
|
||||||
Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl);
|
Exec ("(println (str ""Mal ["" *host-language* ""]""))", Repl);
|
||||||
loop
|
loop
|
||||||
@ -418,16 +450,17 @@ begin
|
|||||||
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
|
||||||
end;
|
end;
|
||||||
-- Other exceptions are really unexpected.
|
-- Other exceptions are really unexpected.
|
||||||
|
|
||||||
|
-- Collect garbage.
|
||||||
|
Err.Data := Mal.Nil;
|
||||||
|
Repl.all.Keep;
|
||||||
|
Garbage_Collected.Clean;
|
||||||
end loop;
|
end loop;
|
||||||
Ada.Text_IO.New_Line;
|
Ada.Text_IO.New_Line;
|
||||||
end if;
|
end if;
|
||||||
|
|
||||||
-- If assertions are enabled, check deallocations.
|
-- If assertions are enabled, check deallocations.
|
||||||
Err.Data := Mal.Nil; -- Remove references to other packages
|
pragma Debug (Garbage_Collected.Clean);
|
||||||
pragma Debug (Envs.Clear_And_Check_Allocations);
|
Garbage_Collected.Check_Allocations;
|
||||||
pragma Debug (Atoms.Check_Allocations);
|
Symbols.Check_Allocations;
|
||||||
pragma Debug (Builtins.Check_Allocations);
|
|
||||||
pragma Debug (Fns.Check_Allocations);
|
|
||||||
pragma Debug (Maps.Check_Allocations);
|
|
||||||
pragma Debug (Sequences.Check_Allocations);
|
|
||||||
pragma Debug (Symbols.Check_Allocations);
|
|
||||||
end StepA_Mal;
|
end StepA_Mal;
|
||||||
|
@ -1,68 +1,41 @@
|
|||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
with Types.Mal;
|
|
||||||
|
with Types.Builtins;
|
||||||
|
with Types.Fns;
|
||||||
|
|
||||||
package body Types.Atoms is
|
package body Types.Atoms is
|
||||||
|
|
||||||
type Rec is limited record
|
|
||||||
Refs : Natural;
|
|
||||||
Data : Mal.T;
|
|
||||||
end record;
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
Object.Ref.all.Refs := @ + 1;
|
|
||||||
end Adjust;
|
|
||||||
|
|
||||||
function Atom (Args : in Mal.T_Array) return Mal.T is
|
function Atom (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
Ref : Mal.Atom_Ptr;
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
Allocations := Allocations + 1;
|
Ref := new Instance'(Garbage_Collected.Instance with
|
||||||
return (Kind_Atom, (Ada.Finalization.Controlled with new Rec'
|
Data => Args (Args'First));
|
||||||
(Refs => 1,
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
Data => Args (Args'First))));
|
return (Kind_Atom, Ref);
|
||||||
end Atom;
|
end Atom;
|
||||||
|
|
||||||
procedure Check_Allocations is
|
|
||||||
begin
|
|
||||||
pragma Assert (Allocations = 0);
|
|
||||||
end Check_Allocations;
|
|
||||||
|
|
||||||
function Deref (Args : in Mal.T_Array) return Mal.T is
|
function Deref (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom");
|
Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom");
|
||||||
return Args (Args'First).Atom.Ref.all.Data;
|
return Args (Args'First).Atom.all.Data;
|
||||||
end Deref;
|
end Deref;
|
||||||
|
|
||||||
function Deref (Item : in Ptr) return Mal.T
|
function Deref (Item : in Instance) return Mal.T
|
||||||
is (Item.Ref.all.Data);
|
is (Item.Data);
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
procedure Keep_References (Object : in out Instance) is
|
||||||
begin
|
begin
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
Mal.Keep (Object.Data);
|
||||||
Object.Ref.all.Refs := @ - 1;
|
end Keep_References;
|
||||||
if 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref := null;
|
|
||||||
else
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Object.Ref);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
function Reset (Args : in Mal.T_Array) return Mal.T is
|
function Reset (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 2, "expected 2 parameters");
|
Err.Check (Args'Length = 2, "expected 2 parameters");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Atom,
|
Err.Check (Args (Args'First).Kind = Kind_Atom,
|
||||||
"parameter 1 must be an atom");
|
"parameter 1 must be an atom");
|
||||||
Args (Args'First).Atom.Ref.all.Data := Args (Args'Last);
|
Args (Args'First).Atom.all.Data := Args (Args'Last);
|
||||||
return Args (Args'Last);
|
return Args (Args'Last);
|
||||||
end Reset;
|
end Reset;
|
||||||
|
|
||||||
@ -73,7 +46,7 @@ package body Types.Atoms is
|
|||||||
"parameter 1 must be an atom");
|
"parameter 1 must be an atom");
|
||||||
declare
|
declare
|
||||||
use type Mal.T_Array;
|
use type Mal.T_Array;
|
||||||
X : Mal.T renames Args (Args'First).Atom.Ref.all.Data;
|
X : Mal.T renames Args (Args'First).Atom.all.Data;
|
||||||
F : Mal.T renames Args (Args'First + 1);
|
F : Mal.T renames Args (Args'First + 1);
|
||||||
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
|
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
|
||||||
begin
|
begin
|
||||||
@ -81,9 +54,9 @@ package body Types.Atoms is
|
|||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
X := F.Builtin.all (A);
|
X := F.Builtin.all (A);
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
X := F.Builtin_With_Meta.Builtin.all (A);
|
X := F.Builtin_With_Meta.all.Builtin.all (A);
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
X := F.Fn.Apply (A);
|
X := F.Fn.all.Apply (A);
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("parameter 2 must be a function");
|
Err.Raise_With ("parameter 2 must be a function");
|
||||||
end case;
|
end case;
|
||||||
|
@ -1,10 +1,9 @@
|
|||||||
private with Ada.Finalization;
|
with Garbage_Collected;
|
||||||
|
with Types.Mal;
|
||||||
limited with Types.Mal;
|
|
||||||
|
|
||||||
package Types.Atoms is
|
package Types.Atoms is
|
||||||
|
|
||||||
type Ptr is private;
|
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||||
|
|
||||||
-- Built-in functions.
|
-- Built-in functions.
|
||||||
function Atom (Args : in Mal.T_Array) return Mal.T;
|
function Atom (Args : in Mal.T_Array) return Mal.T;
|
||||||
@ -13,21 +12,13 @@ package Types.Atoms is
|
|||||||
function Swap (Args : in Mal.T_Array) return Mal.T;
|
function Swap (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
|
||||||
-- Helper for print.
|
-- Helper for print.
|
||||||
function Deref (Item : in Ptr) return Mal.T with Inline;
|
function Deref (Item : in Instance) return Mal.T with Inline;
|
||||||
|
|
||||||
-- Debug.
|
|
||||||
procedure Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
type Rec;
|
type Instance is new Garbage_Collected.Instance with record
|
||||||
type Acc is access Rec;
|
Data : Mal.T;
|
||||||
type Ptr is new Ada.Finalization.Controlled with record
|
end record;
|
||||||
Ref : Acc := null;
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
end record
|
|
||||||
with Invariant => Ptr.Ref /= null;
|
|
||||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
|
||||||
|
|
||||||
end Types.Atoms;
|
end Types.Atoms;
|
||||||
|
@ -1,63 +1,30 @@
|
|||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Types.Mal;
|
|
||||||
|
|
||||||
package body Types.Builtins is
|
package body Types.Builtins is
|
||||||
|
|
||||||
type Rec is limited record
|
function Builtin (Item : in Instance) return Mal.Builtin_Ptr
|
||||||
Builtin : Mal.Builtin_Ptr;
|
is (Item.F_Builtin);
|
||||||
Refs : Natural;
|
|
||||||
Meta : Mal.T;
|
|
||||||
end record;
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
procedure Keep_References (Object : in out Instance) is
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
|
||||||
begin
|
begin
|
||||||
Object.Ref.all.Refs := @ + 1;
|
Mal.Keep (Object.F_Meta);
|
||||||
end Adjust;
|
end Keep_References;
|
||||||
|
|
||||||
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr
|
function Meta (Item : in Instance) return Mal.T
|
||||||
is (Item.Ref.all.Builtin);
|
is (Item.F_Meta);
|
||||||
|
|
||||||
procedure Check_Allocations is
|
|
||||||
begin
|
|
||||||
pragma Assert (Allocations = 0);
|
|
||||||
end Check_Allocations;
|
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref.all.Refs := @ - 1;
|
|
||||||
if 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref := null;
|
|
||||||
else
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Object.Ref);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
function Meta (Item : in Ptr) return Mal.T
|
|
||||||
is (Item.Ref.all.Meta);
|
|
||||||
|
|
||||||
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
||||||
Metadata : in Mal.T) return Mal.T is
|
Metadata : in Mal.T) return Mal.T
|
||||||
|
is
|
||||||
|
Ref : constant Mal.Builtin_With_Meta_Ptr
|
||||||
|
:= new Instance'(Garbage_Collected.Instance with
|
||||||
|
F_Builtin => Builtin,
|
||||||
|
F_Meta => Metadata);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
return (Kind_Builtin_With_Meta,
|
return (Kind_Builtin_With_Meta, Ref);
|
||||||
(Ada.Finalization.Controlled with new Rec'(Builtin => Builtin,
|
|
||||||
Meta => Metadata,
|
|
||||||
Refs => 1)));
|
|
||||||
end With_Meta;
|
end With_Meta;
|
||||||
|
|
||||||
function With_Meta (Item : in Ptr;
|
function With_Meta (Item : in Instance;
|
||||||
Metadata : in Mal.T) return Mal.T
|
Metadata : in Mal.T) return Mal.T
|
||||||
-- Do not try to reuse the memory. We can hope that this kind of
|
is (With_Meta (Item.Builtin, Metadata));
|
||||||
-- nonsense will be rare.
|
|
||||||
is (With_Meta (Item.Ref.all.Builtin, Metadata));
|
|
||||||
|
|
||||||
end Types.Builtins;
|
end Types.Builtins;
|
||||||
|
@ -1,6 +1,5 @@
|
|||||||
private with Ada.Finalization;
|
with Garbage_Collected;
|
||||||
|
with Types.Mal;
|
||||||
limited with Types.Mal;
|
|
||||||
|
|
||||||
package Types.Builtins is
|
package Types.Builtins is
|
||||||
|
|
||||||
@ -9,27 +8,21 @@ package Types.Builtins is
|
|||||||
-- functions. The controlled type below is only useful when one
|
-- functions. The controlled type below is only useful when one
|
||||||
-- has the silly idea to add metadata to a built-in.
|
-- has the silly idea to add metadata to a built-in.
|
||||||
|
|
||||||
type Ptr is tagged private;
|
type Instance is new Garbage_Collected.Instance with private;
|
||||||
|
|
||||||
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
function With_Meta (Builtin : in Mal.Builtin_Ptr;
|
||||||
Metadata : in Mal.T) return Mal.T with Inline;
|
Metadata : in Mal.T) return Mal.T with Inline;
|
||||||
function With_Meta (Item : in Ptr;
|
function With_Meta (Item : in Instance;
|
||||||
Metadata : in Mal.T) return Mal.T with Inline;
|
Metadata : in Mal.T) return Mal.T with Inline;
|
||||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||||
function Builtin (Item : in Ptr) return Mal.Builtin_Ptr with Inline;
|
function Builtin (Item : in Instance) return Mal.Builtin_Ptr with Inline;
|
||||||
|
|
||||||
procedure Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
type Rec;
|
type Instance is new Garbage_Collected.Instance with record
|
||||||
type Acc is access Rec;
|
F_Builtin : Mal.Builtin_Ptr;
|
||||||
type Ptr is new Ada.Finalization.Controlled with record
|
F_Meta : Mal.T;
|
||||||
Ref : Acc := null;
|
end record;
|
||||||
end record
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
with Invariant => Ptr.Ref /= null;
|
|
||||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
|
||||||
|
|
||||||
end Types.Builtins;
|
end Types.Builtins;
|
||||||
|
@ -1,144 +1,86 @@
|
|||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Envs;
|
|
||||||
with Err;
|
with Err;
|
||||||
with Eval_Cb;
|
with Eval_Cb;
|
||||||
with Types.Mal;
|
|
||||||
with Types.Sequences;
|
|
||||||
with Types.Symbols;
|
|
||||||
|
|
||||||
package body Types.Fns is
|
package body Types.Fns is
|
||||||
|
|
||||||
subtype AFC is Ada.Finalization.Controlled;
|
use type Envs.Ptr;
|
||||||
use type Envs.Closure_Ptr;
|
|
||||||
|
|
||||||
type Rec (Params_Last : Natural) is limited record
|
|
||||||
Ast : Mal.T;
|
|
||||||
Refs : Natural := 1;
|
|
||||||
Env : Envs.Closure_Ptr := Envs.Null_Closure;
|
|
||||||
Meta : Mal.T := Mal.Nil;
|
|
||||||
Params : Symbols.Symbol_Array (1 .. Params_Last);
|
|
||||||
end record;
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
function Apply (Item : in Instance;
|
||||||
begin
|
Args : in Mal.T_Array) return Mal.T
|
||||||
Object.Ref.all.Refs := @ + 1;
|
is (Eval_Cb.Cb.all (Ast => Item.F_Ast,
|
||||||
end Adjust;
|
Env => Envs.New_Env (Outer => Item.F_Env,
|
||||||
|
Binds => Item.F_Params,
|
||||||
|
Exprs => Args)));
|
||||||
|
|
||||||
function Apply (Item : in Ptr;
|
function Ast (Item : in Instance) return Mal.T
|
||||||
Args : in Mal.T_Array) return Mal.T is
|
is (Item.F_Ast);
|
||||||
begin
|
|
||||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
|
||||||
return Eval_Cb.Cb.all (Ast => Item.Ref.all.Ast,
|
|
||||||
Env => Envs.Sub (Outer => Item.Ref.all.Env,
|
|
||||||
Binds => Item.Ref.all.Params,
|
|
||||||
Exprs => Args));
|
|
||||||
end Apply;
|
|
||||||
|
|
||||||
function Ast (Item : in Ptr) return Mal.T
|
function Env (Item : in Instance) return Envs.Ptr
|
||||||
is (Item.Ref.all.Ast);
|
is (Item.F_Env);
|
||||||
|
|
||||||
procedure Check_Allocations is
|
procedure Keep_References (Object : in out Instance) is
|
||||||
begin
|
begin
|
||||||
pragma Assert (Allocations = 0);
|
Mal.Keep (Object.F_Ast);
|
||||||
end Check_Allocations;
|
if Object.F_Env /= null then
|
||||||
|
Object.F_Env.all.Keep;
|
||||||
function Env (Item : in Ptr) return Envs.Closure_Ptr is
|
|
||||||
begin
|
|
||||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
|
||||||
return Item.Ref.all.Env;
|
|
||||||
end Env;
|
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref.all.Refs := @ - 1;
|
|
||||||
if 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref := null;
|
|
||||||
else
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Object.Ref);
|
|
||||||
end if;
|
|
||||||
end if;
|
end if;
|
||||||
end Finalize;
|
Mal.Keep (Object.F_Meta);
|
||||||
|
end Keep_References;
|
||||||
|
|
||||||
function Params (Item : in Ptr) return Symbols.Symbol_Array
|
function Meta (Item : in Instance) return Mal.T
|
||||||
is (Item.Ref.all.Params);
|
is (Item.F_Meta);
|
||||||
|
|
||||||
function Meta (Item : in Ptr) return Mal.T is
|
function New_Function (Params : in Sequences.Instance;
|
||||||
begin
|
|
||||||
pragma Assert (Item.Ref.all.Env /= Envs.Null_Closure);
|
|
||||||
return Item.Ref.all.Meta;
|
|
||||||
end Meta;
|
|
||||||
|
|
||||||
function New_Function (Params : in Sequences.Ptr;
|
|
||||||
Ast : in Mal.T;
|
Ast : in Mal.T;
|
||||||
Env : in Envs.Closure_Ptr)
|
Env : in Envs.Ptr)
|
||||||
return Mal.T
|
return Mal.T
|
||||||
is
|
is
|
||||||
Ref : Acc;
|
Ref : constant Mal.Fn_Ptr
|
||||||
|
:= new Instance'(Garbage_Collected.Instance with
|
||||||
|
Last => Params.Length,
|
||||||
|
F_Ast => Ast,
|
||||||
|
F_Env => Env,
|
||||||
|
others => <>);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
-- Avoid exceptions until Ref is controlled.
|
for I in Ref.all.F_Params'Range loop
|
||||||
Ref := new Rec'(Params_Last => Params.Length,
|
Err.Check (Params (I).Kind = Kind_Symbol,
|
||||||
Ast => Ast,
|
"formal parameters must be symbols");
|
||||||
Env => Env,
|
Ref.all.F_Params (I) := Params (I).Symbol;
|
||||||
others => <>);
|
end loop;
|
||||||
return R : constant Mal.T := (Kind_Fn, (AFC with Ref)) do
|
return (Kind_Fn, Ref);
|
||||||
for I in 1 .. Params.Length loop
|
|
||||||
Err.Check (Params (I).Kind = Kind_Symbol,
|
|
||||||
"formal parameters must be symbols");
|
|
||||||
Ref.all.Params (I) := Params (I).Symbol;
|
|
||||||
end loop;
|
|
||||||
end return;
|
|
||||||
end New_Function;
|
end New_Function;
|
||||||
|
|
||||||
function New_Macro (Item : in Ptr) return Mal.T is
|
function New_Macro (Item : in Instance) return Mal.T is
|
||||||
-- Avoid raising an exception until Ref is controlled.
|
Ref : constant Mal.Fn_Ptr
|
||||||
Ref : Acc := Item.Ref;
|
:= new Instance'(Garbage_Collected.Instance with
|
||||||
|
Last => Item.Last,
|
||||||
|
F_Params => Item.F_Params,
|
||||||
|
F_Ast => Item.F_Ast,
|
||||||
|
others => <>);
|
||||||
begin
|
begin
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
if Ref.all.Refs = 1 then
|
return (Kind_Macro, Ref);
|
||||||
Ref.all.Refs := 2;
|
|
||||||
Ref.all.Env := Envs.Null_Closure;
|
|
||||||
-- Finalize the environment, it will not be used anymore.
|
|
||||||
Ref.all.Meta := Mal.Nil;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
|
|
||||||
Params => Ref.all.Params,
|
|
||||||
Ast => Ref.all.Ast,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return (Kind_Macro, (AFC with Ref));
|
|
||||||
end New_Macro;
|
end New_Macro;
|
||||||
|
|
||||||
function With_Meta (Item : in Ptr;
|
function Params (Item : in Instance) return Symbols.Symbol_Array
|
||||||
|
is (Item.F_Params);
|
||||||
|
|
||||||
|
function With_Meta (Item : in Instance;
|
||||||
Metadata : in Mal.T) return Mal.T
|
Metadata : in Mal.T) return Mal.T
|
||||||
is
|
is
|
||||||
-- Avoid raising an exception until Ref is controlled.
|
Ref : constant Mal.Fn_Ptr
|
||||||
Ref : Acc := Item.Ref;
|
:= new Instance'(Garbage_Collected.Instance with
|
||||||
|
Last => Item.Last,
|
||||||
|
F_Params => Item.F_Params,
|
||||||
|
F_Ast => Item.F_Ast,
|
||||||
|
F_Env => Item.F_Env,
|
||||||
|
F_Meta => Metadata);
|
||||||
begin
|
begin
|
||||||
pragma Assert (Ref.all.Env /= Envs.Null_Closure);
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
return (Kind_Fn, Ref);
|
||||||
if Ref.all.Refs = 1 then
|
|
||||||
Ref.all.Refs := 2;
|
|
||||||
Ref.all.Meta := Metadata;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Params_Last => Ref.all.Params_Last,
|
|
||||||
Params => Ref.all.Params,
|
|
||||||
Ast => Ref.all.Ast,
|
|
||||||
Env => Ref.all.Env,
|
|
||||||
Meta => Metadata,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return (Kind_Fn, (AFC with Ref));
|
|
||||||
end With_Meta;
|
end With_Meta;
|
||||||
|
|
||||||
end Types.Fns;
|
end Types.Fns;
|
||||||
|
@ -1,52 +1,48 @@
|
|||||||
private with Ada.Finalization;
|
with Envs;
|
||||||
|
with Garbage_Collected;
|
||||||
limited with Envs;
|
with Types.Mal;
|
||||||
limited with Types.Mal;
|
with Types.Sequences;
|
||||||
limited with Types.Sequences;
|
with Types.Symbols;
|
||||||
limited with Types.Symbols;
|
|
||||||
|
|
||||||
package Types.Fns is
|
package Types.Fns is
|
||||||
|
|
||||||
type Ptr is tagged private;
|
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||||
-- A pointer to an user-defined function or macro.
|
-- A pointer to an user-defined function or macro.
|
||||||
|
|
||||||
function New_Function (Params : in Sequences.Ptr;
|
function New_Function (Params : in Types.Sequences.Instance;
|
||||||
Ast : in Mal.T;
|
Ast : in Mal.T;
|
||||||
Env : in Envs.Closure_Ptr) return Mal.T
|
Env : in Envs.Ptr) return Mal.T
|
||||||
with Inline;
|
with Inline;
|
||||||
-- Raise an exception if Params contains something else than symbols.
|
-- Raise an exception if Params contains something else than symbols.
|
||||||
|
|
||||||
function New_Macro (Item : in Ptr) return Mal.T with Inline;
|
function New_Macro (Item : in Instance) return Mal.T with Inline;
|
||||||
|
|
||||||
function Params (Item : in Ptr) return Symbols.Symbol_Array with Inline;
|
function Params (Item : in Instance) return Symbols.Symbol_Array
|
||||||
function Ast (Item : in Ptr) return Mal.T with Inline;
|
with Inline;
|
||||||
|
function Ast (Item : in Instance) return Mal.T with Inline;
|
||||||
-- Useful to print.
|
-- Useful to print.
|
||||||
|
|
||||||
function Apply (Item : in Ptr;
|
function Apply (Item : in Instance;
|
||||||
Args : in Mal.T_Array) return Mal.T with Inline;
|
Args : in Mal.T_Array) return Mal.T with Inline;
|
||||||
-- Fails for macros.
|
-- Returns null for macros.
|
||||||
|
|
||||||
function Env (Item : in Ptr) return Envs.Closure_Ptr with Inline;
|
function Env (Item : in Instance) return Envs.Ptr with Inline;
|
||||||
-- Fails for macros. Required for TCO, instead of Apply.
|
-- Returns null for macros.
|
||||||
|
-- Required for TCO, instead of Apply.
|
||||||
|
|
||||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||||
-- Fails for macros.
|
function With_Meta (Item : in Instance;
|
||||||
function With_Meta (Item : in Ptr;
|
|
||||||
Metadata : in Mal.T) return Mal.T with Inline;
|
Metadata : in Mal.T) return Mal.T with Inline;
|
||||||
-- Fails for macros.
|
|
||||||
|
|
||||||
procedure Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
type Rec;
|
type Instance (Last : Natural) is new Garbage_Collected.Instance
|
||||||
type Acc is access Rec;
|
with record
|
||||||
type Ptr is new Ada.Finalization.Controlled with record
|
F_Ast : Mal.T;
|
||||||
Ref : Acc := null;
|
F_Env : Envs.Ptr;
|
||||||
end record
|
F_Meta : Mal.T;
|
||||||
with Invariant => Ptr.Ref /= null;
|
F_Params : Symbols.Symbol_Array (1 .. Last);
|
||||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
end record;
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
|
||||||
|
|
||||||
end Types.Fns;
|
end Types.Fns;
|
||||||
|
@ -1,8 +1,14 @@
|
|||||||
|
with Types.Atoms;
|
||||||
|
with Types.Builtins;
|
||||||
|
with Types.Maps;
|
||||||
|
with Types.Sequences;
|
||||||
|
with Types.Fns;
|
||||||
|
|
||||||
package body Types.Mal is
|
package body Types.Mal is
|
||||||
|
|
||||||
use type Ada.Strings.Unbounded.Unbounded_String;
|
use type Ada.Strings.Unbounded.Unbounded_String;
|
||||||
use type Maps.Ptr;
|
use type Maps.Instance;
|
||||||
use type Sequences.Ptr;
|
use type Sequences.Instance;
|
||||||
use type Symbols.Ptr;
|
use type Symbols.Ptr;
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
@ -22,11 +28,31 @@ package body Types.Mal is
|
|||||||
Right.Kind = Left.Kind and then Left.S = Right.S,
|
Right.Kind = Left.Kind and then Left.S = Right.S,
|
||||||
-- Here comes the part that differs from the predefined equality.
|
-- Here comes the part that differs from the predefined equality.
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
Right.Kind in Kind_Sequence and then Left.Sequence = Right.Sequence,
|
Right.Kind in Kind_Sequence
|
||||||
|
and then Left.Sequence.all = Right.Sequence.all,
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
Right.Kind = Kind_Map and then Left.Map = Right.Map,
|
Right.Kind = Kind_Map and then Left.Map.all = Right.Map.all,
|
||||||
-- Also, comparing functions is an interesting problem.
|
-- Also, comparing functions is an interesting problem.
|
||||||
when others =>
|
when others =>
|
||||||
False);
|
False);
|
||||||
|
|
||||||
|
procedure Keep (Object : in T) is
|
||||||
|
begin
|
||||||
|
case Object.Kind is
|
||||||
|
when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Key | Kind_Builtin
|
||||||
|
| Kind_Symbol =>
|
||||||
|
null;
|
||||||
|
when Kind_Atom =>
|
||||||
|
Object.Atom.all.Keep;
|
||||||
|
when Kind_Sequence =>
|
||||||
|
Object.Sequence.all.Keep;
|
||||||
|
when Kind_Map =>
|
||||||
|
Object.Map.all.Keep;
|
||||||
|
when Kind_Builtin_With_Meta =>
|
||||||
|
Object.Builtin_With_Meta.all.Keep;
|
||||||
|
when Kind_Fn | Kind_Macro =>
|
||||||
|
Object.Fn.all.Keep;
|
||||||
|
end case;
|
||||||
|
end Keep;
|
||||||
|
|
||||||
end Types.Mal;
|
end Types.Mal;
|
||||||
|
@ -1,10 +1,10 @@
|
|||||||
with Ada.Strings.Unbounded;
|
with Ada.Strings.Unbounded;
|
||||||
|
|
||||||
with Types.Atoms;
|
limited with Types.Atoms;
|
||||||
with Types.Builtins;
|
limited with Types.Builtins;
|
||||||
with Types.Fns;
|
limited with Types.Fns;
|
||||||
with Types.Maps;
|
limited with Types.Maps;
|
||||||
with Types.Sequences;
|
limited with Types.Sequences;
|
||||||
with Types.Symbols;
|
with Types.Symbols;
|
||||||
|
|
||||||
package Types.Mal is
|
package Types.Mal is
|
||||||
@ -48,7 +48,13 @@ package Types.Mal is
|
|||||||
|
|
||||||
type T;
|
type T;
|
||||||
type T_Array;
|
type T_Array;
|
||||||
|
|
||||||
|
type Atom_Ptr is access Atoms.Instance;
|
||||||
type Builtin_Ptr is access function (Args : in T_Array) return T;
|
type Builtin_Ptr is access function (Args : in T_Array) return T;
|
||||||
|
type Builtin_With_Meta_Ptr is access Builtins.Instance;
|
||||||
|
type Fn_Ptr is access Fns.Instance;
|
||||||
|
type Map_Ptr is access Maps.Instance;
|
||||||
|
type Sequence_Ptr is access Sequences.Instance;
|
||||||
|
|
||||||
type T (Kind : Kind_Type := Kind_Nil) is record
|
type T (Kind : Kind_Type := Kind_Nil) is record
|
||||||
case Kind is
|
case Kind is
|
||||||
@ -59,21 +65,21 @@ package Types.Mal is
|
|||||||
when Kind_Number =>
|
when Kind_Number =>
|
||||||
Number : Integer;
|
Number : Integer;
|
||||||
when Kind_Atom =>
|
when Kind_Atom =>
|
||||||
Atom : Atoms.Ptr;
|
Atom : Atom_Ptr;
|
||||||
when Kind_Key =>
|
when Kind_Key =>
|
||||||
S : Ada.Strings.Unbounded.Unbounded_String;
|
S : Ada.Strings.Unbounded.Unbounded_String;
|
||||||
when Kind_Symbol =>
|
when Kind_Symbol =>
|
||||||
Symbol : Symbols.Ptr;
|
Symbol : Symbols.Ptr;
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
Sequence : Sequences.Ptr;
|
Sequence : Sequence_Ptr;
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
Map : Maps.Ptr;
|
Map : Map_Ptr;
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
Builtin : Builtin_Ptr;
|
Builtin : Builtin_Ptr;
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
Builtin_With_Meta : Builtins.Ptr;
|
Builtin_With_Meta : Builtin_With_Meta_Ptr;
|
||||||
when Kind_Fn | Kind_Macro =>
|
when Kind_Fn | Kind_Macro =>
|
||||||
Fn : Fns.Ptr;
|
Fn : Fn_Ptr;
|
||||||
end case;
|
end case;
|
||||||
end record;
|
end record;
|
||||||
|
|
||||||
@ -83,6 +89,8 @@ package Types.Mal is
|
|||||||
|
|
||||||
Nil : constant T := (Kind => Kind_Nil);
|
Nil : constant T := (Kind => Kind_Nil);
|
||||||
|
|
||||||
|
procedure Keep (Object : in Mal.T) with Inline;
|
||||||
|
|
||||||
type T_Array is array (Positive range <>) of T;
|
type T_Array is array (Positive range <>) of T;
|
||||||
|
|
||||||
end Types.Mal;
|
end Types.Mal;
|
||||||
|
@ -1,151 +1,77 @@
|
|||||||
with Ada.Containers.Hashed_Maps;
|
|
||||||
with Ada.Strings.Unbounded.Hash;
|
with Ada.Strings.Unbounded.Hash;
|
||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
with Types.Sequences;
|
with Types.Sequences;
|
||||||
with Types.Mal;
|
|
||||||
|
|
||||||
package body Types.Maps is
|
package body Types.Maps is
|
||||||
|
|
||||||
subtype AFC is Ada.Finalization.Controlled;
|
function Constructor return Mal.Map_Ptr with Inline;
|
||||||
use type Ada.Containers.Count_Type;
|
|
||||||
|
|
||||||
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type
|
|
||||||
with Inline;
|
|
||||||
-- This function also checks the kind of the key, and raise an
|
|
||||||
-- error in case of problem.
|
|
||||||
|
|
||||||
package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
|
|
||||||
Element_Type => Mal.T,
|
|
||||||
Hash => Hash,
|
|
||||||
Equivalent_Keys => Mal."=",
|
|
||||||
"=" => Mal."=");
|
|
||||||
use type HM.Map;
|
|
||||||
|
|
||||||
type Rec is limited record
|
|
||||||
Refs : Natural := 1;
|
|
||||||
Data : HM.Map := HM.Empty_Map;
|
|
||||||
Meta : Mal.T := Mal.Nil;
|
|
||||||
end record;
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
function "=" (Left, Right : in Ptr) return Boolean
|
function "=" (Left, Right : in Instance) return Boolean
|
||||||
is (Left.Ref.all.Data = Right.Ref.all.Data);
|
is (Left.Data = Right.Data);
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
Object.Ref.all.Refs := @ + 1;
|
|
||||||
end Adjust;
|
|
||||||
|
|
||||||
function Assoc (Args : in Mal.T_Array) return Mal.T is
|
function Assoc (Args : in Mal.T_Array) return Mal.T is
|
||||||
Ref : Acc;
|
Ref : constant Mal.Map_Ptr := Constructor;
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
|
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||||
"parameter 1 must be a map");
|
"parameter 1 must be a map");
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref.all.Data := Args (Args'First).Map.all.Data;
|
||||||
Ref := Args (Args'First).Map.Ref;
|
for I in 1 .. Args'Length / 2 loop
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
|
||||||
if Ref.all.Refs = 1 then
|
New_Item => Args (Args'First + 2 * I));
|
||||||
Ref.all.Refs := 2;
|
-- This call checks the kind of the key.
|
||||||
Ref.all.Meta := Mal.Nil;
|
end loop;
|
||||||
else
|
return (Kind_Map, Ref);
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Data => Ref.all.Data,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
|
||||||
for I in 1 .. Args'Length / 2 loop
|
|
||||||
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
|
|
||||||
New_Item => Args (Args'First + 2 * I));
|
|
||||||
-- This call checks the kind of the key.
|
|
||||||
end loop;
|
|
||||||
end return;
|
|
||||||
end Assoc;
|
end Assoc;
|
||||||
|
|
||||||
procedure Check_Allocations is
|
|
||||||
begin
|
|
||||||
pragma Assert (Allocations = 0);
|
|
||||||
end Check_Allocations;
|
|
||||||
|
|
||||||
function Contains (Args : in Mal.T_Array) return Mal.T is
|
function Contains (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 2, "expected 2 parameters");
|
Err.Check (Args'Length = 2, "expected 2 parameters");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||||
"parameter 1 must be a map");
|
"parameter 1 must be a map");
|
||||||
return (Kind_Boolean,
|
return (Kind_Boolean,
|
||||||
Args (Args'First).Map.Ref.all.Data.Contains (Args (Args'Last)));
|
Args (Args'First).Map.all.Data.Contains (Args (Args'Last)));
|
||||||
end Contains;
|
end Contains;
|
||||||
|
|
||||||
|
function Constructor return Mal.Map_Ptr is
|
||||||
|
Ref : constant Mal.Map_Ptr := new Instance;
|
||||||
|
begin
|
||||||
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
|
return Ref;
|
||||||
|
end Constructor;
|
||||||
|
|
||||||
function Dissoc (Args : in Mal.T_Array) return Mal.T is
|
function Dissoc (Args : in Mal.T_Array) return Mal.T is
|
||||||
Ref : Acc;
|
Ref : constant Mal.Map_Ptr := Constructor;
|
||||||
begin
|
begin
|
||||||
Err.Check (0 < Args'Length, "expected at least 1 parameter");
|
Err.Check (0 < Args'Length, "expected at least 1 parameter");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||||
"parameter 1 must be a map");
|
"parameter 1 must be a map");
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref.all.Data := Args (Args'First).Map.all.Data;
|
||||||
Ref := Args (Args'First).Map.Ref;
|
for I in Args'First + 1 .. Args'Last loop
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Ref.all.Data.Exclude (Args (I));
|
||||||
if Ref.all.Refs = 1 then
|
-- This call checks the kind of the key.
|
||||||
Ref.all.Refs := 2;
|
end loop;
|
||||||
Ref.all.Meta := Mal.Nil;
|
return (Kind_Map, Ref);
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Data => Ref.all.Data,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
|
||||||
for I in Args'First + 1 .. Args'Last loop
|
|
||||||
Ref.all.Data.Exclude (Args (I));
|
|
||||||
-- This call checks the kind of the key.
|
|
||||||
end loop;
|
|
||||||
end return;
|
|
||||||
end Dissoc;
|
end Dissoc;
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
function Generic_Eval (Container : in Instance;
|
||||||
begin
|
Env : in Env_Type) return Mal.T
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref.all.Refs := @ - 1;
|
|
||||||
if 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref := null;
|
|
||||||
else
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Object.Ref);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
function Generic_Eval (Container : in Ptr;
|
|
||||||
Env : in Env_Type)
|
|
||||||
return Mal.T
|
|
||||||
is
|
is
|
||||||
-- Copy the whole hash in order to avoid recomputing the hash
|
-- Copy the whole hash in order to avoid recomputing the hash
|
||||||
-- for each key, even if it implies unneeded calls to adjust
|
-- for each key, even if it implies unneeded calls to adjust
|
||||||
-- and finalize for Mal_Type values.
|
-- and finalize for Mal_Type values.
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref : constant Mal.Map_Ptr := Constructor;
|
||||||
Ref : Acc := Container.Ref;
|
|
||||||
begin
|
begin
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Ref.Data := Container.Data;
|
||||||
if Ref.all.Refs = 1 then
|
for Position in Ref.all.Data.Iterate loop
|
||||||
Ref.all.Refs := 2;
|
Ref.all.Data.Replace_Element (Position,
|
||||||
Ref.all.Meta := Mal.Nil;
|
Eval (HM.Element (Position), Env));
|
||||||
else
|
-- This call may raise exceptions.
|
||||||
Allocations := Allocations + 1;
|
end loop;
|
||||||
Ref := new Rec'(Data => Ref.all.Data,
|
return Mal.T'(Kind_Map, Ref);
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
|
||||||
for Position in Ref.all.Data.Iterate loop
|
|
||||||
Ref.all.Data.Replace_Element (Position,
|
|
||||||
Eval (HM.Element (Position), Env));
|
|
||||||
-- This call may raise exceptions.
|
|
||||||
end loop;
|
|
||||||
end return;
|
|
||||||
end Generic_Eval;
|
end Generic_Eval;
|
||||||
|
|
||||||
function Get (Args : in Mal.T_Array) return Mal.T is
|
function Get (Args : in Mal.T_Array) return Mal.T is
|
||||||
@ -158,8 +84,7 @@ package body Types.Maps is
|
|||||||
"key must be a keyword or string");
|
"key must be a keyword or string");
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
when Kind_Map =>
|
when Kind_Map =>
|
||||||
Position
|
Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last));
|
||||||
:= Args (Args'First).Map.Ref.all.Data.Find (Args (Args'Last));
|
|
||||||
-- This call checks the kind of the key.
|
-- This call checks the kind of the key.
|
||||||
if HM.Has_Element (Position) then
|
if HM.Has_Element (Position) then
|
||||||
return HM.Element (Position);
|
return HM.Element (Position);
|
||||||
@ -179,86 +104,83 @@ package body Types.Maps is
|
|||||||
|
|
||||||
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
|
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
|
||||||
Binds : constant Natural := Args'Length / 2;
|
Binds : constant Natural := Args'Length / 2;
|
||||||
Ref : Acc;
|
Ref : Mal.Map_Ptr;
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
|
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
|
||||||
Allocations := Allocations + 1;
|
Ref := Constructor;
|
||||||
-- Avoid exceptions until Ref is controlled.
|
|
||||||
Ref := new Rec;
|
|
||||||
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
|
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
|
||||||
return R : constant Mal.T := (Kind_Map, (AFC with Ref)) do
|
for I in 0 .. Binds - 1 loop
|
||||||
for I in 0 .. Binds - 1 loop
|
Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
|
||||||
Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
|
New_Item => Args (Args'First + 2 * I + 1));
|
||||||
New_Item => Args (Args'First + 2 * I + 1));
|
-- This call checks the kind of the key.
|
||||||
-- This call checks the kind of the key.
|
end loop;
|
||||||
end loop;
|
return (Kind_Map, Ref);
|
||||||
end return;
|
|
||||||
end Hash_Map;
|
end Hash_Map;
|
||||||
|
|
||||||
procedure Iterate (Container : in Ptr) is
|
procedure Iterate (Container : in Instance) is
|
||||||
begin
|
begin
|
||||||
for Position in Container.Ref.all.Data.Iterate loop
|
for Position in Container.Data.Iterate loop
|
||||||
Process (HM.Key (Position), HM.Element (Position));
|
Process (HM.Key (Position), HM.Element (Position));
|
||||||
end loop;
|
end loop;
|
||||||
end Iterate;
|
end Iterate;
|
||||||
|
|
||||||
|
procedure Keep_References (Object : in out Instance) is
|
||||||
|
begin
|
||||||
|
for Position in Object.Data.Iterate loop
|
||||||
|
Mal.Keep (HM.Key (Position));
|
||||||
|
Mal.Keep (HM.Element (Position));
|
||||||
|
end loop;
|
||||||
|
Mal.Keep (Object.F_Meta);
|
||||||
|
end Keep_References;
|
||||||
|
|
||||||
function Keys (Args : in Mal.T_Array) return Mal.T is
|
function Keys (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
A1 : Mal.Map_Ptr;
|
||||||
|
R : Mal.Sequence_Ptr;
|
||||||
|
I : Positive := 1;
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||||
"parameter 1 must be a map");
|
"parameter 1 must be a map");
|
||||||
declare
|
A1 := Args (Args'First).Map;
|
||||||
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
|
R := Sequences.Constructor (A1.all.Length);
|
||||||
R : Mal.T_Array (1 .. Natural (A1.Length));
|
for Position in A1.all.Data.Iterate loop
|
||||||
I : Positive := 1;
|
R.all.Replace_Element (I, HM.Key (Position));
|
||||||
begin
|
I := I + 1;
|
||||||
for Position in A1.Iterate loop
|
end loop;
|
||||||
R (I) := HM.Key (Position);
|
return (Kind_List, R);
|
||||||
I := I + 1;
|
|
||||||
end loop;
|
|
||||||
return Sequences.List (R);
|
|
||||||
end;
|
|
||||||
end Keys;
|
end Keys;
|
||||||
|
|
||||||
function Meta (Container : in Ptr) return Mal.T
|
function Length (Container : in Instance) return Natural
|
||||||
is (Container.Ref.all.Meta);
|
is (Natural (Container.Data.Length));
|
||||||
|
|
||||||
|
function Meta (Container : in Instance) return Mal.T
|
||||||
|
is (Container.F_Meta);
|
||||||
|
|
||||||
function Vals (Args : in Mal.T_Array) return Mal.T is
|
function Vals (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
A1 : Mal.Map_Ptr;
|
||||||
|
R : Mal.Sequence_Ptr;
|
||||||
|
I : Positive := 1;
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
Err.Check (Args (Args'First).Kind = Kind_Map,
|
Err.Check (Args (Args'First).Kind = Kind_Map,
|
||||||
"parameter 1 must be a map");
|
"parameter 1 must be a map");
|
||||||
declare
|
A1 := Args (Args'First).Map;
|
||||||
A1 : HM.Map renames Args (Args'First).Map.Ref.all.Data;
|
R := Sequences.Constructor (A1.all.Length);
|
||||||
R : Mal.T_Array (1 .. Natural (A1.Length));
|
for Element of A1.all.Data loop
|
||||||
I : Positive := 1;
|
R.all.Replace_Element (I, Element);
|
||||||
begin
|
I := I + 1;
|
||||||
for Element of A1 loop
|
end loop;
|
||||||
R (I) := Element;
|
return (Kind_List, R);
|
||||||
I := I + 1;
|
|
||||||
end loop;
|
|
||||||
return Sequences.List (R);
|
|
||||||
end;
|
|
||||||
end Vals;
|
end Vals;
|
||||||
|
|
||||||
function With_Meta (Data : in Ptr;
|
function With_Meta (Data : in Instance;
|
||||||
Metadata : in Mal.T)
|
Metadata : in Mal.T) return Mal.T
|
||||||
return Mal.T
|
|
||||||
is
|
is
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref : constant Mal.Map_Ptr := Constructor;
|
||||||
Ref : Acc := Data.Ref;
|
|
||||||
begin
|
begin
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Ref.all.Data := Data.Data;
|
||||||
if Ref.all.Refs = 1 then
|
Ref.all.F_Meta := Metadata;
|
||||||
Ref.all.Refs := 2;
|
return (Kind_Map, Ref);
|
||||||
Ref.all.Meta := Metadata;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Data => Ref.all.Data,
|
|
||||||
Meta => Metadata,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return (Kind_Map, (AFC with Ref));
|
|
||||||
end With_Meta;
|
end With_Meta;
|
||||||
|
|
||||||
end Types.Maps;
|
end Types.Maps;
|
||||||
|
@ -1,10 +1,11 @@
|
|||||||
private with Ada.Finalization;
|
private with Ada.Containers.Hashed_Maps;
|
||||||
|
|
||||||
limited with Types.Mal;
|
with Garbage_Collected;
|
||||||
|
with Types.Mal;
|
||||||
|
|
||||||
package Types.Maps is
|
package Types.Maps is
|
||||||
|
|
||||||
type Ptr is tagged private;
|
type Instance (<>) is new Garbage_Collected.Instance with private;
|
||||||
|
|
||||||
-- Built-in functions.
|
-- Built-in functions.
|
||||||
function Assoc (Args : in Mal.T_Array) return Mal.T;
|
function Assoc (Args : in Mal.T_Array) return Mal.T;
|
||||||
@ -15,17 +16,19 @@ package Types.Maps is
|
|||||||
function Keys (Args : in Mal.T_Array) return Mal.T;
|
function Keys (Args : in Mal.T_Array) return Mal.T;
|
||||||
function Vals (Args : in Mal.T_Array) return Mal.T;
|
function Vals (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
|
||||||
|
function "=" (Left, Right : in Instance) return Boolean with Inline;
|
||||||
|
|
||||||
-- A generic is better than an access to function because of
|
-- A generic is better than an access to function because of
|
||||||
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
|
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
|
||||||
|
|
||||||
-- Used to evaluate each element of a map.
|
-- Used to evaluate each element of a map.
|
||||||
-- Eval is generic because units cannot depend on each other.
|
|
||||||
generic
|
generic
|
||||||
type Env_Type (<>) is limited private;
|
type Env_Type (<>) is limited private;
|
||||||
with function Eval (Ast : in Mal.T;
|
with function Eval (Ast : in Mal.T;
|
||||||
Env : in Env_Type)
|
Env : in Env_Type)
|
||||||
return Mal.T;
|
return Mal.T;
|
||||||
function Generic_Eval (Container : in Ptr;
|
function Generic_Eval (Container : in Instance;
|
||||||
Env : in Env_Type)
|
Env : in Env_Type)
|
||||||
return Mal.T;
|
return Mal.T;
|
||||||
|
|
||||||
@ -33,28 +36,32 @@ package Types.Maps is
|
|||||||
generic
|
generic
|
||||||
with procedure Process (Key : in Mal.T;
|
with procedure Process (Key : in Mal.T;
|
||||||
Element : in Mal.T);
|
Element : in Mal.T);
|
||||||
procedure Iterate (Container : in Ptr);
|
procedure Iterate (Container : in Instance);
|
||||||
|
|
||||||
function Meta (Container : in Ptr) return Mal.T with Inline;
|
function Length (Container : in Instance) return Natural with Inline;
|
||||||
|
|
||||||
function With_Meta (Data : in Ptr;
|
function Meta (Container : in Instance) return Mal.T with Inline;
|
||||||
|
function With_Meta (Data : in Instance;
|
||||||
Metadata : in Mal.T)
|
Metadata : in Mal.T)
|
||||||
return Mal.T;
|
return Mal.T;
|
||||||
|
|
||||||
-- Debug
|
|
||||||
procedure Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
type Rec;
|
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline;
|
||||||
type Acc is access Rec;
|
-- This function also checks the kind of the key, and raise an
|
||||||
type Ptr is new Ada.Finalization.Controlled with record
|
-- error in case of problem.
|
||||||
Ref : Acc := null;
|
|
||||||
end record
|
package HM is new Ada.Containers.Hashed_Maps (Key_Type => Mal.T,
|
||||||
with Invariant => Ptr.Ref /= null;
|
Element_Type => Mal.T,
|
||||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
Hash => Hash,
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
Equivalent_Keys => Mal."=",
|
||||||
overriding function "=" (Left, Right : in Ptr) return Boolean with Inline;
|
"=" => Mal."=");
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
use type HM.Map;
|
||||||
|
|
||||||
|
type Instance is new Garbage_Collected.Instance with record
|
||||||
|
Data : HM.Map;
|
||||||
|
F_Meta : Mal.T;
|
||||||
|
end record;
|
||||||
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
|
|
||||||
end Types.Maps;
|
end Types.Maps;
|
||||||
|
@ -1,68 +1,44 @@
|
|||||||
with Ada.Unchecked_Deallocation;
|
|
||||||
|
|
||||||
with Err;
|
with Err;
|
||||||
with Types.Mal;
|
with Types.Builtins;
|
||||||
|
with Types.Fns;
|
||||||
|
|
||||||
package body Types.Sequences is
|
package body Types.Sequences is
|
||||||
|
|
||||||
subtype AFC is Ada.Finalization.Controlled;
|
|
||||||
use type Mal.T_Array;
|
use type Mal.T_Array;
|
||||||
|
|
||||||
type Rec (Last : Natural) is limited record
|
|
||||||
Refs : Natural := 1;
|
|
||||||
Meta : Mal.T := Mal.Nil;
|
|
||||||
Data : Mal.T_Array (1 .. Last) := (others => Mal.Nil);
|
|
||||||
end record;
|
|
||||||
|
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
|
||||||
Allocations : Natural := 0;
|
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
function "=" (Left, Right : in Ptr) return Boolean is
|
function "=" (Left, Right : in Instance) return Boolean is
|
||||||
-- Should become Left.Ref.all.Data = Right.Ref.all.Data when
|
-- Should become Left.Ref.all.Data = Right.Ref.all.Data when
|
||||||
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
|
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
|
||||||
use type Mal.T;
|
use type Mal.T;
|
||||||
L : Rec renames Left.Ref.all;
|
|
||||||
R : Rec renames Right.Ref.all;
|
|
||||||
begin
|
begin
|
||||||
return L.Last = R.Last
|
return Left.Last = Right.Last
|
||||||
and then (for all I in 1 .. L.Last => L.Data (I) = R.Data (I));
|
and then
|
||||||
|
(for all I in 1 .. Left.Last => Left.Data (I) = Right.Data (I));
|
||||||
end "=";
|
end "=";
|
||||||
|
|
||||||
function "&" (Left : in Mal.T_Array;
|
function "&" (Left : in Mal.T_Array;
|
||||||
Right : in Ptr) return Mal.T_Array
|
Right : in Instance) return Mal.T_Array
|
||||||
is (Left & Right.Ref.all.Data);
|
is (Left & Right.Data);
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
Object.Ref.all.Refs := @ + 1;
|
|
||||||
end Adjust;
|
|
||||||
|
|
||||||
procedure Check_Allocations is
|
|
||||||
begin
|
|
||||||
pragma Assert (Allocations = 0);
|
|
||||||
end Check_Allocations;
|
|
||||||
|
|
||||||
function Concat (Args : in Mal.T_Array) return Mal.T is
|
function Concat (Args : in Mal.T_Array) return Mal.T is
|
||||||
Sum : Natural := 0;
|
Sum : Natural := 0;
|
||||||
First : Positive := 1;
|
First : Positive := 1;
|
||||||
Last : Natural;
|
Last : Natural;
|
||||||
Ref : Acc;
|
Ref : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
for Arg of Args loop
|
for Arg of Args loop
|
||||||
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences");
|
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences");
|
||||||
Sum := Sum + Arg.Sequence.Ref.all.Data'Length;
|
Sum := Sum + Arg.Sequence.all.Data'Length;
|
||||||
end loop;
|
end loop;
|
||||||
Allocations := Allocations + 1;
|
Ref := Constructor (Sum);
|
||||||
-- Avoid exceptions until Ref is controlled.
|
|
||||||
Ref := new Rec (Sum);
|
|
||||||
for Arg of Args loop
|
for Arg of Args loop
|
||||||
Last := First - 1 + Arg.Sequence.Ref.all.Data'Length;
|
Last := First - 1 + Arg.Sequence.all.Data'Length;
|
||||||
Ref.all.Data (First .. Last) := Arg.Sequence.Ref.all.Data;
|
Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
|
||||||
First := Last + 1;
|
First := Last + 1;
|
||||||
end loop;
|
end loop;
|
||||||
return (Kind_List, (AFC with Ref));
|
return (Kind_List, Ref);
|
||||||
end Concat;
|
end Concat;
|
||||||
|
|
||||||
function Conj (Args : in Mal.T_Array) return Mal.T is
|
function Conj (Args : in Mal.T_Array) return Mal.T is
|
||||||
@ -71,21 +47,20 @@ package body Types.Sequences is
|
|||||||
case Args (Args'First).Kind is
|
case Args (Args'First).Kind is
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
declare
|
declare
|
||||||
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||||
Last : constant Natural := Args'Length - 1 + Data'Length;
|
Last : constant Natural := Args'Length - 1 + Data'Length;
|
||||||
-- Avoid exceptions until Ref is controlled.
|
-- Avoid exceptions until Ref is controlled.
|
||||||
Ref : constant Acc := new Rec (Last);
|
Ref : constant Mal.Sequence_Ptr := Constructor (Last);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
|
||||||
if Args (Args'First).Kind = Kind_List then
|
if Args (Args'First).Kind = Kind_List then
|
||||||
for I in 1 .. Args'Length - 1 loop
|
for I in 1 .. Args'Length - 1 loop
|
||||||
Ref.all.Data (I) := Args (Args'Last - I + 1);
|
Ref.all.Data (I) := Args (Args'Last - I + 1);
|
||||||
end loop;
|
end loop;
|
||||||
Ref.all.Data (Args'Length .. Last) := Data;
|
Ref.all.Data (Args'Length .. Last) := Data;
|
||||||
return (Kind_List, (AFC with Ref));
|
return (Kind_List, Ref);
|
||||||
else
|
else
|
||||||
Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
|
Ref.all.Data := Data & Args (Args'First + 1 .. Args'Last);
|
||||||
return (Kind_Vector, (AFC with Ref));
|
return (Kind_Vector, Ref);
|
||||||
end if;
|
end if;
|
||||||
end;
|
end;
|
||||||
when others =>
|
when others =>
|
||||||
@ -100,15 +75,21 @@ package body Types.Sequences is
|
|||||||
"parameter 2 must be a sequence");
|
"parameter 2 must be a sequence");
|
||||||
declare
|
declare
|
||||||
Head : Mal.T renames Args (Args'First);
|
Head : Mal.T renames Args (Args'First);
|
||||||
Tail : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
|
Tail : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
|
||||||
|
Ref : constant Mal.Sequence_Ptr := Constructor (1 + Tail'Length);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
Ref.all.Data := Head & Tail;
|
||||||
return (Kind_List, (AFC with new Rec'(Last => 1 + Tail'Length,
|
return (Kind_List, Ref);
|
||||||
Data => Head & Tail,
|
|
||||||
others => <>)));
|
|
||||||
end;
|
end;
|
||||||
end Cons;
|
end Cons;
|
||||||
|
|
||||||
|
function Constructor (Length : in Natural) return Mal.Sequence_Ptr is
|
||||||
|
Ref : constant Mal.Sequence_Ptr := new Instance (Length);
|
||||||
|
begin
|
||||||
|
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
|
||||||
|
return Ref;
|
||||||
|
end Constructor;
|
||||||
|
|
||||||
function Count (Args : in Mal.T_Array) return Mal.T is
|
function Count (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
@ -116,28 +97,15 @@ package body Types.Sequences is
|
|||||||
when Kind_Nil =>
|
when Kind_Nil =>
|
||||||
return (Kind_Number, 0);
|
return (Kind_Number, 0);
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
return (Kind_Number, Args (Args'First).Sequence.Ref.all.Data'Length);
|
return (Kind_Number, Args (Args'First).Sequence.all.Data'Length);
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("parameter must be nil or a sequence");
|
Err.Raise_With ("parameter must be nil or a sequence");
|
||||||
end case;
|
end case;
|
||||||
end Count;
|
end Count;
|
||||||
|
|
||||||
function Element (Container : in Ptr;
|
function Element (Container : in Instance;
|
||||||
Index : in Positive) return Mal.T
|
Index : in Positive) return Mal.T
|
||||||
is (Container.Ref.all.Data (Index));
|
is (Container.Data (Index));
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
|
||||||
begin
|
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref.all.Refs := @ - 1;
|
|
||||||
if 0 < Object.Ref.all.Refs then
|
|
||||||
Object.Ref := null;
|
|
||||||
else
|
|
||||||
Allocations := Allocations - 1;
|
|
||||||
Free (Object.Ref);
|
|
||||||
end if;
|
|
||||||
end if;
|
|
||||||
end Finalize;
|
|
||||||
|
|
||||||
function First (Args : in Mal.T_Array) return Mal.T is
|
function First (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
@ -147,7 +115,7 @@ package body Types.Sequences is
|
|||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
declare
|
declare
|
||||||
Data : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||||
begin
|
begin
|
||||||
if Data'Length = 0 then
|
if Data'Length = 0 then
|
||||||
return Mal.Nil;
|
return Mal.Nil;
|
||||||
@ -160,48 +128,30 @@ package body Types.Sequences is
|
|||||||
end case;
|
end case;
|
||||||
end First;
|
end First;
|
||||||
|
|
||||||
function Generic_Eval (Container : in Ptr;
|
|
||||||
Env : in Env_Type)
|
|
||||||
return Ptr
|
|
||||||
is
|
|
||||||
-- Avoid exceptions until Ref is controlled.
|
|
||||||
Ref : Acc := Container.Ref;
|
|
||||||
begin
|
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
|
||||||
if Ref.all.Refs = 1 then
|
|
||||||
Ref.all.Refs := 2;
|
|
||||||
Ref.all.Meta := Mal.Nil;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec (Ref.all.Last);
|
|
||||||
end if;
|
|
||||||
return R : constant Ptr := (AFC with Ref) do
|
|
||||||
for I in Container.Ref.all.Data'Range loop
|
|
||||||
Ref.all.Data (I) := Eval (Container.Ref.all.Data (I), Env);
|
|
||||||
-- This call may raise exceptions.
|
|
||||||
-- The target may be the source.
|
|
||||||
end loop;
|
|
||||||
end return;
|
|
||||||
end Generic_Eval;
|
|
||||||
|
|
||||||
function Is_Empty (Args : in Mal.T_Array) return Mal.T is
|
function Is_Empty (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
Err.Check (Args (Args'First).Kind in Kind_Sequence,
|
Err.Check (Args (Args'First).Kind in Kind_Sequence,
|
||||||
"parameter must be a sequence");
|
"parameter must be a sequence");
|
||||||
return (Kind_Boolean,
|
return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
|
||||||
Args (Args'First).Sequence.Ref.all.Data'Length = 0);
|
|
||||||
end Is_Empty;
|
end Is_Empty;
|
||||||
|
|
||||||
function Length (Source : in Ptr) return Natural
|
procedure Keep_References (Object : in out Instance) is
|
||||||
is (Source.Ref.all.Data'Length);
|
begin
|
||||||
|
Mal.Keep (Object.F_Meta);
|
||||||
|
for M of Object.Data loop
|
||||||
|
Mal.Keep (M);
|
||||||
|
end loop;
|
||||||
|
end Keep_References;
|
||||||
|
|
||||||
|
function Length (Source : in Instance) return Natural
|
||||||
|
is (Source.Data'Length);
|
||||||
|
|
||||||
function List (Args : in Mal.T_Array) return Mal.T is
|
function List (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
Ref.all.Data := Args;
|
||||||
return (Kind_List, (AFC with new Rec'(Data => Args,
|
return (Kind_List, Ref);
|
||||||
Last => Args'Length,
|
|
||||||
others => <>)));
|
|
||||||
end List;
|
end List;
|
||||||
|
|
||||||
function Map (Args : in Mal.T_Array) return Mal.T is
|
function Map (Args : in Mal.T_Array) return Mal.T is
|
||||||
@ -211,44 +161,32 @@ package body Types.Sequences is
|
|||||||
"parameter 2 must be a sequence");
|
"parameter 2 must be a sequence");
|
||||||
declare
|
declare
|
||||||
F : Mal.T renames Args (Args'First);
|
F : Mal.T renames Args (Args'First);
|
||||||
Src : Mal.T_Array renames Args (Args'Last).Sequence.Ref.all.Data;
|
Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length);
|
||||||
Ref : Acc := Args (Args'Last).Sequence.Ref;
|
|
||||||
begin
|
begin
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
case F.Kind is
|
||||||
if Ref.all.Refs = 1 then
|
|
||||||
Ref.all.Refs := 2;
|
|
||||||
Ref.all.Meta := Mal.Nil;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec (Ref.all.Last);
|
|
||||||
end if;
|
|
||||||
return R : constant Mal.T := (Kind_List, (AFC with Ref)) do
|
|
||||||
case F.Kind is
|
|
||||||
when Kind_Builtin =>
|
when Kind_Builtin =>
|
||||||
for I in Src'Range loop
|
for I in Src'Range loop
|
||||||
Ref.all.Data (I) := F.Builtin.all (Src (I .. I));
|
Ref.all.Data (I) := F.Builtin.all (Src (I .. I));
|
||||||
-- This call may raise exceptions.
|
|
||||||
-- The target may be the same storage than the source.
|
|
||||||
end loop;
|
end loop;
|
||||||
when Kind_Builtin_With_Meta =>
|
when Kind_Builtin_With_Meta =>
|
||||||
for I in Src'Range loop
|
for I in Src'Range loop
|
||||||
Ref.all.Data (I)
|
Ref.all.Data (I)
|
||||||
:= F.Builtin_With_Meta.Builtin.all (Src (I .. I));
|
:= F.Builtin_With_Meta.all.Builtin.all (Src (I .. I));
|
||||||
end loop;
|
end loop;
|
||||||
when Kind_Fn =>
|
when Kind_Fn =>
|
||||||
for I in Src'Range loop
|
for I in Src'Range loop
|
||||||
Ref.all.Data (I) := F.Fn.Apply (Src (I .. I));
|
Ref.all.Data (I) := F.Fn.all.Apply (Src (I .. I));
|
||||||
end loop;
|
end loop;
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("parameter 1 must be a function");
|
Err.Raise_With ("parameter 1 must be a function");
|
||||||
end case;
|
end case;
|
||||||
end return;
|
return (Kind_List, Ref);
|
||||||
end;
|
end;
|
||||||
end Map;
|
end Map;
|
||||||
|
|
||||||
function Meta (Item : in Ptr) return Mal.T
|
function Meta (Item : in Instance) return Mal.T
|
||||||
is (Item.Ref.all.Meta);
|
is (Item.F_Meta);
|
||||||
|
|
||||||
function Nth (Args : in Mal.T_Array) return Mal.T is
|
function Nth (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
@ -258,7 +196,7 @@ package body Types.Sequences is
|
|||||||
Err.Check (Args (Args'Last).Kind = Kind_Number,
|
Err.Check (Args (Args'Last).Kind = Kind_Number,
|
||||||
"parameter 2 must be a number");
|
"parameter 2 must be a number");
|
||||||
declare
|
declare
|
||||||
L : Mal.T_Array renames Args (Args'First).Sequence.Ref.all.Data;
|
L : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
|
||||||
I : constant Integer := Args (Args'Last).Number + 1;
|
I : constant Integer := Args (Args'Last).Number + 1;
|
||||||
begin
|
begin
|
||||||
Err.Check (I in L'Range, "index out of bounds");
|
Err.Check (I in L'Range, "index out of bounds");
|
||||||
@ -266,70 +204,62 @@ package body Types.Sequences is
|
|||||||
end;
|
end;
|
||||||
end Nth;
|
end Nth;
|
||||||
|
|
||||||
|
procedure Replace_Element (Container : in out Instance;
|
||||||
|
Index : in Positive;
|
||||||
|
New_Item : in Mal.T)
|
||||||
|
is
|
||||||
|
begin
|
||||||
|
Container.Data (Index) := New_Item;
|
||||||
|
end Replace_Element;
|
||||||
|
|
||||||
function Rest (Args : in Mal.T_Array) return Mal.T is
|
function Rest (Args : in Mal.T_Array) return Mal.T is
|
||||||
begin
|
begin
|
||||||
Err.Check (Args'Length = 1, "expected 1 parameter");
|
Err.Check (Args'Length = 1, "expected 1 parameter");
|
||||||
declare
|
declare
|
||||||
A1 : Mal.T renames Args (Args'First);
|
A1 : Mal.T renames Args (Args'First);
|
||||||
Ref : Acc;
|
Ref : Mal.Sequence_Ptr;
|
||||||
begin
|
begin
|
||||||
-- Avoid exceptions until Ref is controlled.
|
-- Avoid exceptions until Ref is controlled.
|
||||||
case A1.Kind is
|
case A1.Kind is
|
||||||
when Kind_Nil =>
|
when Kind_Nil =>
|
||||||
Allocations := Allocations + 1;
|
Ref := Constructor (0);
|
||||||
Ref := new Rec (0);
|
|
||||||
when Kind_Sequence =>
|
when Kind_Sequence =>
|
||||||
Allocations := Allocations + 1;
|
if A1.Sequence.all.Last = 0 then
|
||||||
if A1.Sequence.Ref.all.Last = 0 then
|
Ref := Constructor (0);
|
||||||
Ref := new Rec (0);
|
|
||||||
else
|
else
|
||||||
Ref := new Rec'
|
Ref := Constructor (A1.Sequence.all.Last - 1);
|
||||||
(Last => A1.Sequence.Ref.all.Last - 1,
|
Ref.all.Data
|
||||||
Data => A1.Sequence.Ref.all.Data
|
:= A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last);
|
||||||
(2 .. A1.Sequence.Ref.all.Data'Last),
|
|
||||||
others => <>);
|
|
||||||
end if;
|
end if;
|
||||||
when others =>
|
when others =>
|
||||||
Err.Raise_With ("parameter must be nil or a sequence");
|
Err.Raise_With ("parameter must be nil or a sequence");
|
||||||
end case;
|
end case;
|
||||||
return (Kind_List, (AFC with Ref));
|
return (Kind_List, Ref);
|
||||||
end;
|
end;
|
||||||
end Rest;
|
end Rest;
|
||||||
|
|
||||||
function Tail (Source : in Ptr;
|
function Tail (Source : in Instance;
|
||||||
Count : in Natural) return Mal.T_Array is
|
Count : in Natural) return Mal.T_Array is
|
||||||
Data : Mal.T_Array renames Source.Ref.all.Data;
|
Data : Mal.T_Array renames Source.Data;
|
||||||
begin
|
begin
|
||||||
return Data (Data'Last - Count + 1 .. Data'Last);
|
return Data (Data'Last - Count + 1 .. Data'Last);
|
||||||
end Tail;
|
end Tail;
|
||||||
|
|
||||||
function Vector (Args : in Mal.T_Array) return Mal.T is
|
function Vector (Args : in Mal.T_Array) return Mal.T is
|
||||||
|
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
|
||||||
begin
|
begin
|
||||||
Allocations := Allocations + 1;
|
Ref.all.Data := Args;
|
||||||
return (Kind_Vector, (AFC with new Rec'(Data => Args,
|
return (Kind_Vector, Ref);
|
||||||
Last => Args'Length,
|
|
||||||
others => <>)));
|
|
||||||
end Vector;
|
end Vector;
|
||||||
|
|
||||||
function With_Meta (Data : in Ptr;
|
function With_Meta (Data : in Instance;
|
||||||
Metadata : in Mal.T) return Ptr
|
Metadata : in Mal.T) return Mal.Sequence_Ptr
|
||||||
is
|
is
|
||||||
-- Avoid exceptions until Ref is controlled.
|
Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last);
|
||||||
Ref : Acc := Data.Ref;
|
|
||||||
|
|
||||||
begin
|
begin
|
||||||
pragma Assert (0 < Ref.all.Refs);
|
Ref.all.Data := Data.Data;
|
||||||
if Ref.all.Refs = 1 then
|
Ref.all.F_Meta := Metadata;
|
||||||
Ref.all.Refs := 2;
|
return Ref;
|
||||||
Ref.all.Meta := Metadata;
|
|
||||||
else
|
|
||||||
Allocations := Allocations + 1;
|
|
||||||
Ref := new Rec'(Last => Ref.all.Last,
|
|
||||||
Data => Ref.all.Data,
|
|
||||||
Meta => Metadata,
|
|
||||||
others => <>);
|
|
||||||
end if;
|
|
||||||
return (AFC with Ref);
|
|
||||||
end With_Meta;
|
end With_Meta;
|
||||||
|
|
||||||
end Types.Sequences;
|
end Types.Sequences;
|
||||||
|
@ -1,10 +1,9 @@
|
|||||||
private with Ada.Finalization;
|
with Garbage_Collected;
|
||||||
|
with Types.Mal;
|
||||||
limited with Types.Mal;
|
|
||||||
|
|
||||||
package Types.Sequences is
|
package Types.Sequences is
|
||||||
|
|
||||||
type Ptr is tagged private
|
type Instance (<>) is new Garbage_Collected.Instance with private
|
||||||
with Constant_Indexing => Element;
|
with Constant_Indexing => Element;
|
||||||
|
|
||||||
-- Built-in functions.
|
-- Built-in functions.
|
||||||
@ -20,59 +19,41 @@ package Types.Sequences is
|
|||||||
function Rest (Args : in Mal.T_Array) return Mal.T;
|
function Rest (Args : in Mal.T_Array) return Mal.T;
|
||||||
function Vector (Args : in Mal.T_Array) return Mal.T;
|
function Vector (Args : in Mal.T_Array) return Mal.T;
|
||||||
|
|
||||||
function Length (Source : in Ptr) return Natural with Inline;
|
function "=" (Left, Right : in Instance) return Boolean with Inline;
|
||||||
|
|
||||||
function Element (Container : in Ptr;
|
function Length (Source : in Instance) return Natural with Inline;
|
||||||
|
|
||||||
|
function Element (Container : in Instance;
|
||||||
Index : in Positive) return Mal.T
|
Index : in Positive) return Mal.T
|
||||||
with Inline, Pre => Index <= Length (Container);
|
with Inline, Pre => Index <= Length (Container);
|
||||||
|
|
||||||
function "&" (Left : in Mal.T_Array;
|
function "&" (Left : in Mal.T_Array;
|
||||||
Right : in Ptr) return Mal.T_Array;
|
Right : in Instance) return Mal.T_Array with Inline;
|
||||||
-- Used to implement Core.Apply.
|
-- Used to implement Core.Apply.
|
||||||
|
|
||||||
-- Used to evaluate each element of a list/vector.
|
function Constructor (Length : in Natural) return Mal.Sequence_Ptr
|
||||||
-- Eval is generic because units cannot depend on each other.
|
with Inline;
|
||||||
generic
|
procedure Replace_Element (Container : in out Instance;
|
||||||
type Env_Type (<>) is limited private;
|
Index : in Positive;
|
||||||
with function Eval (Ast : in Mal.T;
|
New_Item : in Mal.T)
|
||||||
Env : in Env_Type)
|
with Inline, Pre => Index <= Length (Container);
|
||||||
return Mal.T;
|
|
||||||
function Generic_Eval (Container : in Ptr;
|
|
||||||
Env : in Env_Type)
|
|
||||||
return Ptr;
|
|
||||||
|
|
||||||
-- Used in macro implementation.
|
-- Used in macro implementation.
|
||||||
function Tail (Source : in Ptr;
|
function Tail (Source : in Instance;
|
||||||
Count : in Natural) return Mal.T_Array
|
Count : in Natural) return Mal.T_Array
|
||||||
with Inline, Pre => Count <= Length (Source);
|
with Inline, Pre => Count <= Length (Source);
|
||||||
|
|
||||||
function Meta (Item : in Ptr) return Mal.T with Inline;
|
function Meta (Item : in Instance) return Mal.T with Inline;
|
||||||
function With_Meta (Data : in Ptr;
|
function With_Meta (Data : in Instance;
|
||||||
Metadata : in Mal.T)
|
Metadata : in Mal.T)
|
||||||
return Ptr;
|
return Mal.Sequence_Ptr;
|
||||||
|
|
||||||
-- Debug.
|
|
||||||
procedure Check_Allocations;
|
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
-- It is tempting to use null to represent an empty list, but the
|
type Instance (Last : Natural) is new Garbage_Collected.Instance with record
|
||||||
-- performance is not improved much, and the code is more complex.
|
F_Meta : Mal.T;
|
||||||
-- In addition, the empty list may want to carry metadata.
|
Data : Mal.T_Array (1 .. Last);
|
||||||
|
end record;
|
||||||
-- Similarly, always providing a default value like a pointer to a
|
overriding procedure Keep_References (Object : in out Instance) with Inline;
|
||||||
-- static empty list would not gain much, and probably hide some
|
|
||||||
-- bugs.
|
|
||||||
|
|
||||||
type Rec;
|
|
||||||
type Acc is access Rec;
|
|
||||||
type Ptr is new Ada.Finalization.Controlled with record
|
|
||||||
Ref : Acc := null;
|
|
||||||
end record
|
|
||||||
with Invariant => Ptr.Ref /= null;
|
|
||||||
overriding procedure Adjust (Object : in out Ptr) with Inline;
|
|
||||||
overriding procedure Finalize (Object : in out Ptr) with Inline;
|
|
||||||
overriding function "=" (Left, Right : in Ptr) return Boolean;
|
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
|
||||||
|
|
||||||
end Types.Sequences;
|
end Types.Sequences;
|
||||||
|
@ -1,42 +1,31 @@
|
|||||||
with Ada.Containers.Ordered_Sets;
|
with Ada.Containers.Hashed_Sets;
|
||||||
with Ada.Strings.Hash;
|
with Ada.Strings.Hash;
|
||||||
with Ada.Unchecked_Deallocation;
|
with Ada.Unchecked_Deallocation;
|
||||||
|
|
||||||
package body Types.Symbols is
|
package body Types.Symbols is
|
||||||
|
|
||||||
-- For the global dictionnary of symbols, an ordered set seems
|
|
||||||
-- better than a hash map.
|
|
||||||
|
|
||||||
type Rec (Last : Positive) is limited record
|
type Rec (Last : Positive) is limited record
|
||||||
Refs : Natural;
|
Refs : Natural;
|
||||||
Hash : Ada.Containers.Hash_Type;
|
|
||||||
Data : String (1 .. Last);
|
Data : String (1 .. Last);
|
||||||
end record;
|
end record;
|
||||||
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
|
||||||
Allocations : Natural := 0;
|
Allocations : Natural := 0;
|
||||||
|
|
||||||
function "<" (Left, Right : in Acc) return Boolean with Inline;
|
function Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline;
|
||||||
function Eq (Left, Right : in Acc) return Boolean with Inline;
|
package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc,
|
||||||
-- It would be unwise to name this function "=" and override the
|
Hash => Hash,
|
||||||
-- predefined equality for Acc.
|
Equivalent_Elements => "=",
|
||||||
-- We only search by key and insert new elements, so this should
|
"=" => "=");
|
||||||
-- always return False.
|
|
||||||
package Sets is new Ada.Containers.Ordered_Sets (Element_Type => Acc,
|
|
||||||
"<" => "<",
|
|
||||||
"=" => Eq);
|
|
||||||
|
|
||||||
function Key (Item : in Acc) return String with Inline;
|
function Key (Item : in Acc) return String with Inline;
|
||||||
package Keys is new Sets.Generic_Keys (Key_Type => String,
|
package Keys is new Sets.Generic_Keys (Key_Type => String,
|
||||||
Key => Key,
|
Key => Key,
|
||||||
"<" => Standard."<");
|
Hash => Ada.Strings.Hash,
|
||||||
|
Equivalent_Keys => "=");
|
||||||
|
|
||||||
Dict : Sets.Set;
|
Dict : Sets.Set;
|
||||||
|
|
||||||
----------------------------------------------------------------------
|
----------------------------------------------------------------------
|
||||||
|
|
||||||
function "<" (Left, Right : in Acc) return Boolean
|
|
||||||
is (Left.all.Data < Right.all.Data);
|
|
||||||
|
|
||||||
procedure Adjust (Object : in out Ptr) is
|
procedure Adjust (Object : in out Ptr) is
|
||||||
begin
|
begin
|
||||||
Object.Ref.all.Refs := @ + 1;
|
Object.Ref.all.Refs := @ + 1;
|
||||||
@ -59,7 +48,6 @@ package body Types.Symbols is
|
|||||||
else
|
else
|
||||||
Allocations := Allocations + 1;
|
Allocations := Allocations + 1;
|
||||||
Ref := new Rec'(Data => Source,
|
Ref := new Rec'(Data => Source,
|
||||||
Hash => Ada.Strings.Hash (Source),
|
|
||||||
Last => Source'Length,
|
Last => Source'Length,
|
||||||
Refs => 1);
|
Refs => 1);
|
||||||
Dict.Insert (Ref);
|
Dict.Insert (Ref);
|
||||||
@ -67,13 +55,6 @@ package body Types.Symbols is
|
|||||||
return (Ada.Finalization.Controlled with Ref);
|
return (Ada.Finalization.Controlled with Ref);
|
||||||
end Constructor;
|
end Constructor;
|
||||||
|
|
||||||
function Eq (Left, Right : in Acc) return Boolean is
|
|
||||||
begin
|
|
||||||
pragma Assert (Left /= Right);
|
|
||||||
pragma Assert (Left.all.Data /= Right.all.Data);
|
|
||||||
return False;
|
|
||||||
end Eq;
|
|
||||||
|
|
||||||
procedure Finalize (Object : in out Ptr) is
|
procedure Finalize (Object : in out Ptr) is
|
||||||
begin
|
begin
|
||||||
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
if Object.Ref /= null and then 0 < Object.Ref.all.Refs then
|
||||||
@ -88,8 +69,11 @@ package body Types.Symbols is
|
|||||||
end if;
|
end if;
|
||||||
end Finalize;
|
end Finalize;
|
||||||
|
|
||||||
|
function Hash (Item : in Acc) return Ada.Containers.Hash_Type
|
||||||
|
is (Ada.Strings.Hash (Item.all.Data));
|
||||||
|
|
||||||
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
|
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
|
||||||
is (Item.Ref.all.Hash);
|
is (Ada.Strings.Hash (Item.Ref.all.Data));
|
||||||
|
|
||||||
function Key (Item : in Acc) return String
|
function Key (Item : in Acc) return String
|
||||||
is (Item.all.Data);
|
is (Item.all.Data);
|
||||||
|
@ -3,6 +3,10 @@ private with Ada.Finalization;
|
|||||||
|
|
||||||
package Types.Symbols with Preelaborate is
|
package Types.Symbols with Preelaborate is
|
||||||
|
|
||||||
|
-- Like keys, symbols are immutable final nodes in the internal
|
||||||
|
-- data structures. For them, reference counting is probably more
|
||||||
|
-- efficient than garbage collecting.
|
||||||
|
|
||||||
type Ptr is tagged private;
|
type Ptr is tagged private;
|
||||||
|
|
||||||
function Constructor (Source : in String) return Ptr with Inline;
|
function Constructor (Source : in String) return Ptr with Inline;
|
||||||
@ -13,12 +17,18 @@ package Types.Symbols with Preelaborate is
|
|||||||
-- probability to end up as keys in an environment.
|
-- probability to end up as keys in an environment.
|
||||||
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline;
|
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline;
|
||||||
|
|
||||||
-- Equality compares the contents.
|
-- The implementation ensures that a given content is only
|
||||||
|
-- allocated once, so equality of pointers gives the same result
|
||||||
|
-- than comparing the strings.
|
||||||
|
|
||||||
type Symbol_Array is array (Positive range <>) of Symbols.Ptr;
|
type Symbol_Array is array (Positive range <>) of Ptr;
|
||||||
|
Empty_Array : constant Symbol_Array;
|
||||||
|
-- It is convenient to define this here because the default value
|
||||||
|
-- for Ptr is invalid.
|
||||||
|
|
||||||
-- Debug.
|
-- Debug.
|
||||||
procedure Check_Allocations;
|
procedure Check_Allocations with Inline;
|
||||||
|
-- Does nothing if assertions are disabled.
|
||||||
|
|
||||||
private
|
private
|
||||||
|
|
||||||
@ -49,4 +59,9 @@ private
|
|||||||
-- Predefined equality is fine.
|
-- Predefined equality is fine.
|
||||||
pragma Finalize_Storage_Only (Ptr);
|
pragma Finalize_Storage_Only (Ptr);
|
||||||
|
|
||||||
|
Empty_Array : constant Symbol_Array
|
||||||
|
:= (1 .. 0 => (Ada.Finalization.Controlled with null));
|
||||||
|
-- This will not trigger the invariant check because no element is
|
||||||
|
-- ever actually instantiated.
|
||||||
|
|
||||||
end Types.Symbols;
|
end Types.Symbols;
|
||||||
|
Loading…
Reference in New Issue
Block a user