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

Clarify and optimize ada.2.

Browse Source 
Makefile:
Drop OPT and -gnat2020, not used anymore.
Simplify file list now that each unit has a body.

README:
Remove obsolete items.

Global:
Restrict most pointers to a provable non-null value.

Types: merge intermediate Types.Mal into the Types package.  (the
intermediate package was created in order to prevent a circular
dependency, but is not needed anymore).
Most of the noise in the diff is caused by this change.
This allows to remove most Elaboration pragmas.
Declare most types abstract in the visible part,
enforcing the use of the constructor outside the declaring package.

Envs:
Replace the Get recursion with a more efficient loop.
Use MAL objects as key, string pointers do not change speed.
This delegates some checks from the step files.
Split the constructor and Set_Binds, so that an existing environment
can be reused during TCO.

Err:
Attempt to group the calls.
Avoid computing the message when the assertion holds.

Fns:
Declare and use the eval callback only here.
Separate function and macro interfaces.
Keep a reference to the provided parameter list instead of copying them.

Garbage_Collected:
Make explicit that Keep is not inherited.

Printer:
Remove obsolete inline indications and redundant Print_Function helper.

Maps:
Provide a cleaner interface copied from standard library.

Sequences: stop encapsulating the implementation because of the
performance hit.

Steps:
Move map and vector evaluations into separate functions for readability.
Replace return blocks with normal blocks (MAL values are not finalized
anymore).
Rename standard arrays instead of sequence_ptr when possible.
Remove some duplication and indentation from the apply phase.
Move the frequent special forms in front of the test cascade.
When an environment has been created in the same Eval, reuse it.

Strings:
Use the same garbage-collected storage model for all strings.
This seems faster than the default (mutable) string types.
Hide most of the implementation to avoid leaks.

Symbols: stop ensuring unique allocation of symbols. The reduced
garbage collection and comparison time was compensed by the
maintainance of a global hash.
This commit is contained in:
Nicolas Boulenguez 2019-05-02 21:19:34 +02:00
parent 60e3f6fd6b
commit 8185fe141c
47 changed files with 2527 additions and 2423 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

41
ada.2/Makefile
View File

@ -9,7 +9,7 @@ else
endif
# Compiler arguments.
CARGS = -gnat2020 $(OPT) $(ADAFLAGS)
CARGS = $(ADAFLAGS)
# Linker arguments.
LARGS = $(LDFLAGS) -lreadline
@ -33,25 +33,26 @@ clean:
# Tell Make how to detect out-of-date executables, and let gnatmake do
# the rest when it must be executed.
TYPES := \
envs.ads envs.adb \
err.ads err.adb \
eval_cb.ads \
garbage_collected.ads garbage_collected.adb \
printer.ads printer.adb \
reader.ads reader.adb \
readline.ads \
types-atoms.ads types-atoms.adb \
types-builtins.ads types-builtins.adb \
types-fns.ads types-fns.adb \
types-sequences.ads types-sequences.adb \
types-mal.ads types-mal.adb \
types-maps.ads types-maps.adb \
types-symbols-names.ads \
types-symbols.ads types-symbols.adb \
types.ads
CORE := \
core.ads core.adb
sources = $(foreach unit,$1,$(unit).adb $(unit).ads)
TYPES := $(call sources,\
envs \
err \
garbage_collected \
printer \
reader \
readline \
types \
types-atoms \
types-builtins \
types-fns \
types-macros \
types-maps \
types-sequences \
types-strings \
)
CORE := $(call sources,\
core \
)
$(step0) : %: %.adb
$(step13): %: %.adb $(TYPES)

48
ada.2/README
View File

@ -2,62 +2,38 @@ Comparison with the first Ada implementation.
--
The first implementation was deliberately compatible with all Ada
compilers, while this one illustrates various Ada 2020 features:
compilers, while this one illustrates various Ada 2012 features:
assertions, preconditions, invariants, initial assignment for limited
types, limited imports, indexing aspects...
types, limited imports...
The variant MAL type is implemented with a discriminant instead of
object-style dispatching. This allows more static and dynamic checks,
but also two crucial performance improvements:
* Nil, boolean, integers and pointers to built-in functions are passed
by value without dynamic allocation.
* Lists are implemented as C-style arrays, and most of them can be
* Lists are implemented as C-style arrays, and can often be
allocated on the stack.
Another difference is that a minimal form of garbage collecting is
implemented, removing objects not referenced from the main
environment. Reference counting is convenient for symbols or strings,
but never deallocates cyclic structures. The implementation collects
environment. Reference counting does not seem efficient even for symbols,
and 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.
It is possible to execute the recursion marking references in parallel
with the recursion printing the result, which does not modify anything
and ignores the reference marking. This works but is less performant
than sequential execution even with Linux threads and a single task
initialized at startup.
Each pointer type goes on using its own memory pool, enabling better
performance when the designated subtype has a fixed size.
The eventual performances compete with C-style languages, allthough
all user input is checked (implicit language-defined checks like array
bounds and discriminant consistency are only enabled during tests).
Notes for contributors that do not fit in a specific package.
--
* All packages can call Eval back via a reference in the Eval_Cb
package, set during startup. I am interested in a prettier solution
ensuring a valid value during elaboration.
Note that generic packages cannot export access values.
* Symbol pointers are non null, new variables must be assigned
immediately. This is usually enforced by a hidden discriminant, but
here we want the type to become a field inside Types.Mal.T. So the
check happens at run time with a private invariant.
The finalize procedure may be called twice, so it does nothing when
the reference count is zero, meaning that we are reaching Finalize
recursively.
* In implementations with reference counting, a consistent object
(that will be deallocated automatically) must be built before any
exception is raised by user code (for example the 'map' built-in
function may run user code). Garbage collection simplifies a lot
this kind of situations.
* Each module encapsulating dynamic allocation counts allocations and
deallocations. With debugging options, a failure is reported if
- too many deallocation happen (via a numeric range check)
- all storage is not freed (via a dedicated call from the step file)
The main program only checks that the garbage collector removes all
allocations at the end of execution.
Debugging
--

417
ada.2/core.adb
View File

@ -4,28 +4,27 @@ with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Err;
with Printer;
with Reader;
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Printer;
with Reader;
with Types.Strings;
package body Core is
use Types;
package ASU renames Ada.Strings.Unbounded;
use all type Types.Kind_Type;
-- Used by time_ms.
Start_Time : constant Ada.Calendar.Time := Ada.Calendar.Clock;
generic
Kind : in Kind_Type;
function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T;
function Generic_Kind_Test (Args : in Mal.T_Array) return Mal.T is
Kind : in Types.Kind_Type;
function Generic_Kind_Test (Args : in Types.T_Array) return Types.T;
function Generic_Kind_Test (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return (Kind_Boolean, Args (Args'First).Kind = Kind);
@ -33,84 +32,82 @@ package body Core is
generic
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 is
function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T;
function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Number,
"parameter 1 must be a number");
Err.Check (Args (Args'Last).Kind = Kind_Number,
"parameter 2 must be a number");
Err.Check (Args'Length = 2
and then Args (Args'First).Kind = Kind_Number
and then Args (Args'Last).Kind = Kind_Number,
"expected two numbers");
return (Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
end Generic_Mal_Operator;
generic
with function Ada_Operator (Left, Right : in Integer) return Boolean;
function Generic_Comparison (Args : in Mal.T_Array) return Mal.T;
function Generic_Comparison (Args : in Mal.T_Array) return Mal.T is
function Generic_Comparison (Args : in Types.T_Array) return Types.T;
function Generic_Comparison (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Number,
"parameter 1 must be a number");
Err.Check (Args (Args'Last).Kind = Kind_Number,
"parameter 2 must be a number");
Err.Check (Args'Length = 2
and then Args (Args'First).Kind = Kind_Number
and then Args (Args'Last).Kind = Kind_Number,
"expected two numbers");
return (Kind_Boolean, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
end Generic_Comparison;
function Addition is new Generic_Mal_Operator ("+");
function Apply (Args : in Mal.T_Array) return Mal.T;
function Apply (Args : in Types.T_Array) return Types.T;
function Division is new Generic_Mal_Operator ("/");
function Equals (Args : in Mal.T_Array) return Mal.T;
function Equals (Args : in Types.T_Array) return Types.T;
function Greater_Equal is new Generic_Comparison (">=");
function Greater_Than is new Generic_Comparison (">");
function Is_Atom is new Generic_Kind_Test (Kind_Atom);
function Is_False (Args : in Mal.T_Array) return Mal.T;
function Is_Function (Args : in Mal.T_Array) return Mal.T;
function Is_False (Args : in Types.T_Array) return Types.T;
function Is_Function (Args : in Types.T_Array) return Types.T;
function Is_Keyword is new Generic_Kind_Test (Kind_Keyword);
function Is_List is new Generic_Kind_Test (Kind_List);
function Is_Macro is new Generic_Kind_Test (Kind_Macro);
function Is_Map is new Generic_Kind_Test (Kind_Map);
function Is_Nil is new Generic_Kind_Test (Kind_Nil);
function Is_Number is new Generic_Kind_Test (Kind_Number);
function Is_Sequential (Args : in Mal.T_Array) return Mal.T;
function Is_Sequential (Args : in Types.T_Array) return Types.T;
function Is_String is new Generic_Kind_Test (Kind_String);
function Is_Symbol is new Generic_Kind_Test (Kind_Symbol);
function Is_True (Args : in Mal.T_Array) return Mal.T;
function Is_True (Args : in Types.T_Array) return Types.T;
function Is_Vector is new Generic_Kind_Test (Kind_Vector);
function Keyword (Args : in Mal.T_Array) return Mal.T;
function Keyword (Args : in Types.T_Array) return Types.T;
function Less_Equal is new Generic_Comparison ("<=");
function Less_Than is new Generic_Comparison ("<");
function Mal_Do (Args : in Mal.T_Array) return Mal.T;
function Meta (Args : in Mal.T_Array) return Mal.T;
function Pr_Str (Args : in Mal.T_Array) return Mal.T;
function Println (Args : in Mal.T_Array) return Mal.T;
function Prn (Args : in Mal.T_Array) return Mal.T;
function Mal_Do (Args : in Types.T_Array) return Types.T;
function Meta (Args : in Types.T_Array) return Types.T;
function Pr_Str (Args : in Types.T_Array) return Types.T;
function Println (Args : in Types.T_Array) return Types.T;
function Prn (Args : in Types.T_Array) return Types.T;
function Product is new Generic_Mal_Operator ("*");
function Read_String (Args : in Mal.T_Array) return Mal.T;
function Readline (Args : in Mal.T_Array) return Mal.T;
function Seq (Args : in Mal.T_Array) return Mal.T;
function Slurp (Args : in Mal.T_Array) return Mal.T;
function Str (Args : in Mal.T_Array) return Mal.T;
function Read_String (Args : in Types.T_Array) return Types.T;
function Readline (Args : in Types.T_Array) return Types.T;
function Seq (Args : in Types.T_Array) return Types.T;
function Slurp (Args : in Types.T_Array) return Types.T;
function Str (Args : in Types.T_Array) return Types.T;
function Subtraction is new Generic_Mal_Operator ("-");
function Symbol (Args : in Mal.T_Array) return Mal.T;
function Time_Ms (Args : in Mal.T_Array) return Mal.T;
function With_Meta (Args : in Mal.T_Array) return Mal.T;
function Symbol (Args : in Types.T_Array) return Types.T;
function Time_Ms (Args : in Types.T_Array) return Types.T;
function With_Meta (Args : in Types.T_Array) return Types.T;
----------------------------------------------------------------------
function Apply (Args : in Mal.T_Array) return Mal.T is
function Apply (Args : in Types.T_Array) return Types.T is
begin
Err.Check (2 <= Args'Length, "expected at least 2 parameters");
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
"last parameter must be a sequence");
Err.Check (2 <= Args'Length
and then Args (Args'Last).Kind in Types.Kind_Sequence,
"expected a function, optional arguments then a sequence");
declare
use type Sequences.Instance;
F : Mal.T renames Args (Args'First);
A : constant Mal.T_Array
use type Types.T_Array;
F : Types.T renames Args (Args'First);
A : constant Types.T_Array
:= Args (Args'First + 1 .. Args'Last - 1)
& Args (Args'Last).Sequence.all;
& Args (Args'Last).Sequence.all.Data;
begin
case F.Kind is
when Kind_Builtin =>
@ -125,60 +122,60 @@ package body Core is
end;
end Apply;
function Equals (Args : in Mal.T_Array) return Mal.T is
use type Mal.T;
function Equals (Args : in Types.T_Array) return Types.T is
use type Types.T;
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
return (Kind_Boolean, Args (Args'First) = Args (Args'Last));
end Equals;
function Is_False (Args : in Mal.T_Array) return Mal.T is
function Is_False (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean
and then not Args (Args'First).Ada_Boolean);
end Is_False;
function Is_Function (Args : in Mal.T_Array) return Mal.T is
function Is_Function (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return (Kind_Boolean, Args (Args'First).Kind in Kind_Function);
return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Function);
end Is_Function;
function Is_Sequential (Args : in Mal.T_Array) return Mal.T is
function Is_Sequential (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return (Kind_Boolean, Args (Args'First).Kind in Kind_Sequence);
return (Kind_Boolean, Args (Args'First).Kind in Types.Kind_Sequence);
end Is_Sequential;
function Is_True (Args : in Mal.T_Array) return Mal.T is
function Is_True (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return (Kind_Boolean, Args (Args'First).Kind = Kind_Boolean
and then Args (Args'First).Ada_Boolean);
end Is_True;
function Keyword (Args : in Mal.T_Array) return Mal.T is
function Keyword (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_String, "expected a string");
return (Kind_Keyword, Args (Args'First).S);
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String,
"expected a string");
return (Kind_Keyword, Args (Args'First).Str);
end Keyword;
function Mal_Do (Args : in Mal.T_Array) return Mal.T is
function Mal_Do (Args : in Types.T_Array) return Types.T is
begin
Err.Check (0 < Args'Length, "expected at least 1 parameter");
return Args (Args'Last);
end Mal_Do;
function Meta (Args : in Mal.T_Array) return Mal.T is
function Meta (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
declare
A1 : Mal.T renames Args (Args'First);
A1 : Types.T renames Args (Args'First);
begin
case A1.Kind is
when Kind_Sequence =>
when Types.Kind_Sequence =>
return A1.Sequence.all.Meta;
when Kind_Map =>
return A1.Map.all.Meta;
@ -187,7 +184,7 @@ package body Core is
when Kind_Builtin_With_Meta =>
return A1.Builtin_With_Meta.all.Meta;
when Kind_Builtin =>
return Mal.Nil;
return Types.Nil;
when others =>
Err.Raise_With ("expected a function, map or sequence");
end case;
@ -195,79 +192,80 @@ package body Core is
end Meta;
procedure NS_Add_To_Repl (Repl : in Envs.Ptr) is
procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr) with Inline;
procedure P (S : in Symbols.Ptr;
B : in Mal.Builtin_Ptr)
procedure P (S : in String;
B : in Types.Builtin_Ptr) with Inline;
procedure P (S : in String;
B : in Types.Builtin_Ptr)
is
begin
Repl.all.Set (S, (Kind_Builtin, B));
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc (S)),
(Kind_Builtin, B));
end P;
begin
P (Symbols.Constructor ("+"), Addition'Access);
P (Symbols.Constructor ("apply"), Apply'Access);
P (Symbols.Constructor ("assoc"), Maps.Assoc'Access);
P (Symbols.Constructor ("atom"), Atoms.Atom'Access);
P (Symbols.Constructor ("concat"), Sequences.Concat'Access);
P (Symbols.Constructor ("conj"), Sequences.Conj'Access);
P (Symbols.Constructor ("cons"), Sequences.Cons'Access);
P (Symbols.Constructor ("contains?"), Maps.Contains'Access);
P (Symbols.Constructor ("count"), Sequences.Count'Access);
P (Symbols.Names.Deref, Atoms.Deref'Access);
P (Symbols.Constructor ("dissoc"), Maps.Dissoc'Access);
P (Symbols.Constructor ("/"), Division'Access);
P (Symbols.Constructor ("do"), Mal_Do'Access);
P (Symbols.Constructor ("="), Equals'Access);
P (Symbols.Constructor ("first"), Sequences.First'Access);
P (Symbols.Constructor ("get"), Maps.Get'Access);
P (Symbols.Constructor (">="), Greater_Equal'Access);
P (Symbols.Constructor (">"), Greater_Than'Access);
P (Symbols.Constructor ("hash-map"), Maps.Hash_Map'Access);
P (Symbols.Constructor ("atom?"), Is_Atom'Access);
P (Symbols.Constructor ("empty?"), Sequences.Is_Empty'Access);
P (Symbols.Constructor ("false?"), Is_False'Access);
P (Symbols.Constructor ("fn?"), Is_Function'Access);
P (Symbols.Constructor ("keyword?"), Is_Keyword'Access);
P (Symbols.Constructor ("list?"), Is_List'Access);
P (Symbols.Constructor ("macro?"), Is_Macro'Access);
P (Symbols.Constructor ("map?"), Is_Map'Access);
P (Symbols.Constructor ("nil?"), Is_Nil'Access);
P (Symbols.Constructor ("number?"), Is_Number'Access);
P (Symbols.Constructor ("sequential?"), Is_Sequential'Access);
P (Symbols.Constructor ("string?"), Is_String'Access);
P (Symbols.Constructor ("symbol?"), Is_Symbol'Access);
P (Symbols.Constructor ("true?"), Is_True'Access);
P (Symbols.Constructor ("vector?"), Is_Vector'Access);
P (Symbols.Constructor ("keys"), Maps.Keys'Access);
P (Symbols.Constructor ("keyword"), Keyword'Access);
P (Symbols.Constructor ("<="), Less_Equal'Access);
P (Symbols.Constructor ("<"), Less_Than'Access);
P (Symbols.Constructor ("list"), Sequences.List'Access);
P (Symbols.Constructor ("map"), Sequences.Map'Access);
P (Symbols.Constructor ("meta"), Meta'Access);
P (Symbols.Constructor ("nth"), Sequences.Nth'Access);
P (Symbols.Constructor ("pr-str"), Pr_Str'Access);
P (Symbols.Constructor ("println"), Println'Access);
P (Symbols.Constructor ("prn"), Prn'Access);
P (Symbols.Constructor ("*"), Product'Access);
P (Symbols.Constructor ("read-string"), Read_String'Access);
P (Symbols.Constructor ("readline"), Readline'Access);
P (Symbols.Constructor ("reset!"), Atoms.Reset'Access);
P (Symbols.Constructor ("rest"), Sequences.Rest'Access);
P (Symbols.Constructor ("seq"), Seq'Access);
P (Symbols.Constructor ("slurp"), Slurp'Access);
P (Symbols.Constructor ("str"), Str'Access);
P (Symbols.Constructor ("-"), Subtraction'Access);
P (Symbols.Constructor ("swap!"), Atoms.Swap'Access);
P (Symbols.Constructor ("symbol"), Symbol'Access);
P (Symbols.Constructor ("throw"), Err.Throw'Access);
P (Symbols.Constructor ("time-ms"), Time_Ms'Access);
P (Symbols.Constructor ("vals"), Maps.Vals'Access);
P (Symbols.Constructor ("vector"), Sequences.Vector'Access);
P (Symbols.Names.With_Meta, With_Meta'Access);
P ("+", Addition'Access);
P ("apply", Apply'Access);
P ("assoc", Types.Maps.Assoc'Access);
P ("atom", Types.Atoms.Atom'Access);
P ("concat", Types.Sequences.Concat'Access);
P ("conj", Types.Sequences.Conj'Access);
P ("cons", Types.Sequences.Cons'Access);
P ("contains?", Types.Maps.Contains'Access);
P ("count", Types.Sequences.Count'Access);
P ("deref", Types.Atoms.Deref'Access);
P ("dissoc", Types.Maps.Dissoc'Access);
P ("/", Division'Access);
P ("do", Mal_Do'Access);
P ("=", Equals'Access);
P ("first", Types.Sequences.First'Access);
P ("get", Types.Maps.Get'Access);
P (">=", Greater_Equal'Access);
P (">", Greater_Than'Access);
P ("hash-map", Types.Maps.Hash_Map'Access);
P ("atom?", Is_Atom'Access);
P ("empty?", Types.Sequences.Is_Empty'Access);
P ("false?", Is_False'Access);
P ("fn?", Is_Function'Access);
P ("keyword?", Is_Keyword'Access);
P ("list?", Is_List'Access);
P ("macro?", Is_Macro'Access);
P ("map?", Is_Map'Access);
P ("nil?", Is_Nil'Access);
P ("number?", Is_Number'Access);
P ("sequential?", Is_Sequential'Access);
P ("string?", Is_String'Access);
P ("symbol?", Is_Symbol'Access);
P ("true?", Is_True'Access);
P ("vector?", Is_Vector'Access);
P ("keys", Types.Maps.Keys'Access);
P ("keyword", Keyword'Access);
P ("<=", Less_Equal'Access);
P ("<", Less_Than'Access);
P ("list", Types.Sequences.List'Access);
P ("map", Types.Sequences.Map'Access);
P ("meta", Meta'Access);
P ("nth", Types.Sequences.Nth'Access);
P ("pr-str", Pr_Str'Access);
P ("println", Println'Access);
P ("prn", Prn'Access);
P ("*", Product'Access);
P ("read-string", Read_String'Access);
P ("readline", Readline'Access);
P ("reset!", Types.Atoms.Reset'Access);
P ("rest", Types.Sequences.Rest'Access);
P ("seq", Seq'Access);
P ("slurp", Slurp'Access);
P ("str", Str'Access);
P ("-", Subtraction'Access);
P ("swap!", Types.Atoms.Swap'Access);
P ("symbol", Symbol'Access);
P ("throw", Err.Throw'Access);
P ("time-ms", Time_Ms'Access);
P ("vals", Types.Maps.Vals'Access);
P ("vector", Types.Sequences.Vector'Access);
P ("with-meta", With_Meta'Access);
end NS_Add_To_Repl;
function Pr_Str (Args : in Mal.T_Array) return Mal.T is
function Pr_Str (Args : in Types.T_Array) return Types.T is
R : ASU.Unbounded_String;
Started : Boolean := False;
begin
@ -279,10 +277,10 @@ package body Core is
end if;
Printer.Pr_Str (R, A);
end loop;
return (Kind_String, R);
return (Kind_String, Types.Strings.Alloc (ASU.To_String (R)));
end Pr_Str;
function Println (Args : in Mal.T_Array) return Mal.T is
function Println (Args : in Types.T_Array) return Types.T is
Started : Boolean := False;
Buffer : ASU.Unbounded_String;
begin
@ -295,63 +293,84 @@ package body Core is
Printer.Pr_Str (Buffer, A, Readably => False);
end loop;
Ada.Text_IO.Unbounded_IO.Put_Line (Buffer);
return Mal.Nil;
return Types.Nil;
end Println;
function Prn (Args : in Mal.T_Array) return Mal.T is
function Prn (Args : in Types.T_Array) return Types.T is
-- Calling Pr_Str would create an intermediate copy.
Buffer : ASU.Unbounded_String;
Started : Boolean := False;
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Pr_Str (Args).S);
return Mal.Nil;
for A of Args loop
if Started then
ASU.Append (Buffer, ' ');
else
Started := True;
end if;
Printer.Pr_Str (Buffer, A);
end loop;
Ada.Text_IO.Unbounded_IO.Put_Line (Buffer);
return Types.Nil;
end Prn;
function Readline (Args : in Mal.T_Array) return Mal.T is
function Readline (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_String, "expected a string");
Ada.Text_IO.Unbounded_IO.Put (Args (Args'First).S);
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String,
"expected a string");
Ada.Text_IO.Put (Args (Args'First).Str.all.To_String);
if Ada.Text_IO.End_Of_File then
return Mal.Nil;
return Types.Nil;
else
return (Kind_String, Ada.Text_IO.Unbounded_IO.Get_Line);
return (Kind_String, Types.Strings.Alloc (Ada.Text_IO.Get_Line));
end if;
end Readline;
function Read_String (Args : in Mal.T_Array) return Mal.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_String, "expected a string");
declare
R : constant Mal.T_Array
:= Reader.Read_Str (ASU.To_String (Args (Args'First).S));
function Read_String (Args : in Types.T_Array) return Types.T is
Result : Types.T;
procedure Process (Element : in String);
procedure Process (Element : in String) is
R : constant Types.T_Array := Reader.Read_Str (Element);
begin
Err.Check (R'Length = 1, "parameter must contain 1 expression");
return R (R'First);
end;
Result := R (R'First);
end Process;
begin
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String,
"expected a string");
Args (Args'First).Str.all.Query_Element (Process'Access);
return Result;
end Read_String;
function Seq (Args : in Mal.T_Array) return Mal.T is
function Seq (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
case Args (Args'First).Kind is
when Kind_Nil =>
return Mal.Nil;
return Types.Nil;
when Kind_String =>
if ASU.Length (Args (Args'First).S) = 0 then
return Mal.Nil;
else
declare
A1 : constant ASU.Unbounded_String := Args (Args'First).S;
R : Mal.T_Array (1 .. ASU.Length (A1));
declare
Result : Types.T;
procedure Process (S : in String);
procedure Process (S : in String) is
begin
for I in R'Range loop
R (I) := (Kind_String, ASU.Unbounded_Slice (A1, I, I));
end loop;
return Sequences.List (R);
end;
end if;
when Kind_Sequence =>
if S'Length = 0 then
Result := Types.Nil;
else
Result := (Kind_List,
Types.Sequences.Constructor (S'Length));
for I in S'Range loop
Result.Sequence.all.Data (S'First - 1 + I)
:= (Kind_String, Types.Strings.Alloc (S (I .. I)));
end loop;
end if;
end Process;
begin
Args (Args'First).Str.all.Query_Element (Process'Access);
return Result;
end;
when Types.Kind_Sequence =>
if Args (Args'First).Sequence.all.Length = 0 then
return Mal.Nil;
return Types.Nil;
else
return (Kind_List, Args (Args'First).Sequence);
end if;
@ -360,20 +379,20 @@ package body Core is
end case;
end Seq;
function Slurp (Args : in Mal.T_Array) return Mal.T is
function Slurp (Args : in Types.T_Array) return Types.T is
use Ada.Text_IO;
File : File_Type;
Buffer : ASU.Unbounded_String;
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_String, "expected a string");
Open (File, In_File, ASU.To_String (Args (Args'First).S));
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String,
"expected a string");
Open (File, In_File, Args (Args'First).Str.all.To_String);
while not End_Of_File (File) loop
ASU.Append (Buffer, Get_Line (File));
ASU.Append (Buffer, Ada.Characters.Latin_1.LF);
end loop;
Close (File);
return (Kind_String, Buffer);
return (Kind_String, Types.Strings.Alloc (ASU.To_String (Buffer)));
exception
-- Catch I/O errors, but not Err.Error...
when E : Status_Error | Name_Error | Use_Error | Mode_Error =>
@ -383,24 +402,23 @@ package body Core is
Err.Raise_In_Mal (E);
end Slurp;
function Str (Args : in Mal.T_Array) return Mal.T is
function Str (Args : in Types.T_Array) return Types.T is
R : ASU.Unbounded_String;
begin
for A of Args loop
Printer.Pr_Str (R, A, Readably => False);
for Arg of Args loop
Printer.Pr_Str (R, Arg, Readably => False);
end loop;
return (Kind_String, R);
return (Kind_String, Types.Strings.Alloc (ASU.To_String (R)));
end Str;
function Symbol (Args : in Mal.T_Array) return Mal.T is
function Symbol (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_String, "expected a string");
return (Kind_Symbol,
Symbols.Constructor (ASU.To_String (Args (Args'First).S)));
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_String,
"expected a string");
return (Kind_Symbol, Args (Args'First).Str);
end Symbol;
function Time_Ms (Args : in Mal.T_Array) return Mal.T is
function Time_Ms (Args : in Types.T_Array) return Types.T is
use type Ada.Calendar.Time;
begin
Err.Check (Args'Length = 0, "expected no parameter");
@ -408,26 +426,35 @@ package body Core is
Integer (1000.0 * (Ada.Calendar.Clock - Start_Time)));
end Time_Ms;
function With_Meta (Args : in Mal.T_Array) return Mal.T is
function With_Meta (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
declare
A1 : Mal.T renames Args (Args'First);
A2 : Mal.T renames Args (Args'Last);
A1 : Types.T renames Args (Args'First);
A2 : Types.T renames Args (Args'Last);
begin
case A1.Kind is
when Kind_Builtin_With_Meta =>
return Builtins.With_Meta (A1.Builtin_With_Meta.all, A2);
return A1.Builtin_With_Meta.all.With_Meta (A2);
when Kind_Builtin =>
return Builtins.With_Meta (A1.Builtin, A2);
return Types.Builtins.With_Meta (A1.Builtin, A2);
when Kind_List =>
return (Kind_List, Sequences.With_Meta (A1.Sequence.all, A2));
return R : constant Types.T
:= Types.Sequences.List (A1.Sequence.all.Data)
do
R.Sequence.all.Meta := A2;
end return;
when Kind_Vector =>
return (Kind_Vector, Sequences.With_Meta (A1.Sequence.all, A2));
return R : constant Types.T
:= Types.Sequences.Vector (A1.Sequence.all.Data)
do
R.Sequence.all.Meta := A2;
end return;
when Kind_Map =>
return Maps.With_Meta (A1.Map.all, A2);
return A1.Map.all.With_Meta (A2);
when Kind_Fn =>
return Fns.With_Meta (A1.Fn.all, A2);
return Types.Fns.New_Function (A1.Fn.all.Params, A1.Fn.all.Ast,
A1.Fn.all.Env, A2);
when others =>
Err.Raise_With
("parameter 1 must be a function, map or sequence");

2
ada.2/core.ads
View File

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

84
ada.2/envs.adb
View File

@ -3,23 +3,23 @@ with Ada.Text_IO.Unbounded_IO;
with Err;
with Printer;
with Types.Sequences;
with Types.Symbols.Names;
package body Envs is
use Types;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
----------------------------------------------------------------------
procedure Dump_Stack (Env : in Instance) is
use Ada.Text_IO;
begin
Put_Line ("environment:");
Put ("environment:");
for P in Env.Data.Iterate loop
-- Do not print builtins for repl.
if HM.Element (P).Kind /= Kind_Builtin or Env.Outer /= null then
Put (" ");
Put (HM.Key (P).To_String);
HM.Key (P).all.Query_Element (Put'Access);
Put (':');
Unbounded_IO.Put (Printer.Pr_Str (HM.Element (P)));
New_Line;
@ -32,70 +32,78 @@ package body Envs is
end Dump_Stack;
function Get (Env : in Instance;
Key : in Symbols.Ptr) return Mal.T
Key : in Types.String_Ptr) return Types.T
is
-- Trust the compiler to detect the tail call. A loop would
-- require a Ptr parameter or a separated first iteration.
Position : constant HM.Cursor := Env.Data.Find (Key);
Position : HM.Cursor := Env.Data.Find (Key);
Ref : Link;
begin
if HM.Has_Element (Position) then
return HM.Element (Position);
if not HM.Has_Element (Position) then
Ref := Env.Outer;
loop
if Ref = null then
-- Not using Err.Check, which would compute the
-- argument even if the assertion holds...
Err.Raise_With ("'" & Key.To_String & "' not found");
end if;
Position := Ref.all.Data.Find (Key);
exit when HM.Has_Element (Position);
Ref := Ref.all.Outer;
end loop;
end if;
Err.Check (Env.Outer /= null,
"'" & Symbols.To_String (Key) & "' not found");
return Env.Outer.all.Get (Key);
return HM.Element (Position);
end Get;
procedure Keep_References (Object : in out Instance) is
-- Same remarks than for Get.
begin
for Element of Object.Data loop
Mal.Keep (Element);
for Position in Object.Data.Iterate loop
HM.Key (Position).all.Keep;
Types.Keep (HM.Element (Position));
end loop;
if Object.Outer /= null then
Object.Outer.all.Keep;
end if;
end Keep_References;
function New_Env (Outer : in Ptr := null;
Binds : in Symbols.Symbol_Array := No_Binds;
Exprs : in Mal.T_Array := No_Exprs) return Ptr
is
use type Symbols.Ptr;
Ref : constant Ptr := new Instance'(Garbage_Collected.Instance with
Outer => Outer,
Data => HM.Empty_Map);
function New_Env (Outer : in Link := null) return Ptr is
Ref : constant Ptr := new Instance;
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
if 2 <= Binds'Length
and then Binds (Binds'Last - 1) = Symbols.Names.Ampersand
then
Ref.all.Outer := Outer;
return Ref;
end New_Env;
procedure Set_Binds (Env : in out Instance;
Binds : in Types.T_Array;
Exprs : in Types.T_Array)
is
begin
if 2 <= Binds'Length and then Binds (Binds'Last - 1).Str.all = "&" then
Err.Check (Binds'Length - 2 <= Exprs'Length,
"not enough actual parameters for vararg function");
for I in 0 .. Binds'Length - 3 loop
Ref.all.Data.Include (Key => Binds (Binds'First + I),
New_Item => Exprs (Exprs'First + I));
Env.Data.Include (Key => Binds (Binds'First + I).Str,
New_Item => Exprs (Exprs'First + I));
end loop;
Ref.all.Data.Include (Key => Binds (Binds'Last),
New_Item => Sequences.List
Env.Data.Include (Key => Binds (Binds'Last).Str,
New_Item => Types.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));
Env.Data.Include (Key => Binds (Binds'First + I).Str,
New_Item => Exprs (Exprs'First + I));
end loop;
end if;
return Ref;
end New_Env;
end Set_Binds;
procedure Set (Env : in out Instance;
Key : in Symbols.Ptr;
New_Item : in Mal.T)
Key : in Types.T;
New_Item : in Types.T)
is
begin
Env.Data.Include (Key, New_Item);
Err.Check (Key.Kind = Kind_Symbol, "environment keys must be symbols");
Env.Data.Include (Key.Str, New_Item);
end Set;
end Envs;

46
ada.2/envs.ads
View File

@ -1,8 +1,7 @@
private with Ada.Containers.Hashed_Maps;
with Garbage_Collected;
with Types.Mal;
with Types.Symbols;
with Types.Strings;
package Envs is
@ -10,23 +9,28 @@ package Envs is
-- parameters to be named like a package dependency, and it seems
-- that readability inside Eval is more important.
type Instance (<>) is new Garbage_Collected.Instance with private;
type Ptr is access Instance;
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
type Link is access Instance;
subtype Ptr is not null Link;
No_Binds : Types.Symbols.Symbol_Array renames Types.Symbols.Empty_Array;
No_Exprs : constant Types.Mal.T_Array := (1 .. 0 => Types.Mal.Nil);
function New_Env (Outer : in Link := null) return Ptr with Inline;
-- Set_Binds is provided as distinct subprograms because we some
-- time spare the creation of a subenvironment.
function New_Env (Outer : in Ptr := null;
Binds : in Types.Symbols.Symbol_Array := No_Binds;
Exprs : in Types.Mal.T_Array := No_Exprs)
return Ptr;
procedure Set_Binds (Env : in out Instance;
Binds : in Types.T_Array;
Exprs : in Types.T_Array);
-- Equivalent to successive calls to Set, except that if Binds
-- ends with "&" followed by a symbol, the trailing symbol
-- receives all remaining values as a list.
function Get (Env : in Instance;
Key : in Types.Symbols.Ptr) return Types.Mal.T;
Key : in Types.String_Ptr) return Types.T;
procedure Set (Env : in out Instance;
Key : in Types.Symbols.Ptr;
New_Item : in Types.Mal.T) with Inline;
Key : in Types.T;
New_Item : in Types.T) with Inline;
-- Raises an exception if Key is not a symbol.
-- Debug.
procedure Dump_Stack (Env : in Instance);
@ -34,14 +38,18 @@ package Envs is
private
package HM is new Ada.Containers.Hashed_Maps
(Key_Type => Types.Symbols.Ptr,
Element_Type => Types.Mal.T,
Hash => Types.Symbols.Hash,
Equivalent_Keys => Types.Symbols."=",
"=" => Types.Mal."=");
(Key_Type => Types.String_Ptr,
Element_Type => Types.T,
Hash => Types.Strings.Hash,
Equivalent_Keys => Types.Strings.Same_Contents,
"=" => Types."=");
-- It may be tempting to subclass Types.Map, but this would not
-- simplify the code much. And adding metadata to a structure that
-- is allocated very often has a cost.
type Instance is new Garbage_Collected.Instance with record
Outer : Ptr;
Outer : Link;
Data : HM.Map;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;

17
ada.2/err.adb
View File

@ -1,16 +1,16 @@
with Ada.Characters.Latin_1;
with Printer;
with Types.Strings;
package body Err is
use Ada.Strings.Unbounded;
use Types;
----------------------------------------------------------------------
procedure Add_Trace_Line (Action : in String;
Ast : in Types.Mal.T)
Ast : in Types.T)
is
begin
Append (Trace, " in ");
@ -31,23 +31,28 @@ package body Err is
procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence) is
Message : String renames Ada.Exceptions.Exception_Information (E);
procedure Process (S : in String);
procedure Process (S : in String) is
begin
Append (Trace, S);
end Process;
begin
Data := (Kind_String, To_Unbounded_String (Message));
Data := (Types.Kind_String, Types.Strings.Alloc (Message));
Set_Unbounded_String (Trace, "Uncaught exception: ");
Append (Trace, Message);
Data.Str.all.Query_Element (Process'Access);
raise Error;
end Raise_In_Mal;
procedure Raise_With (Message : in String) is
begin
Data := (Kind_String, To_Unbounded_String (Message));
Data := (Types.Kind_String, Types.Strings.Alloc (Message));
Set_Unbounded_String (Trace, "Uncaught exception: ");
Append (Trace, Message);
Append (Trace, Ada.Characters.Latin_1.LF);
raise Error;
end Raise_With;
function Throw (Args : in Mal.T_Array) return Mal.T is
function Throw (Args : in Types.T_Array) return Types.T is
begin
Check (Args'Length = 1, "expected 1 parameter");
Data := Args (Args'First);

25
ada.2/err.ads
View File

@ -1,17 +1,16 @@
with Ada.Exceptions;
with Ada.Strings.Unbounded;
with Types.Mal;
with Types;
-- We declare a variable of type Types.T.
pragma Elaborate (Types);
-- We declare a variable of type Types.Mal.T.
pragma Elaborate (Types.Mal);
package Err with Elaborate_Body is
package Err is
-- Error handling.
-- Built-in function.
function Throw (Args : in Types.Mal.T_Array) return Types.Mal.T;
function Throw (Args : in Types.T_Array) return Types.T;
-- Ada exceptions can only carry an immutable String in each
-- occurence, so we require a global variable to store the last
@ -19,27 +18,33 @@ package Err with Elaborate_Body is
-- simple string messages.
Error : exception;
Data : Types.Mal.T;
Data : Types.T;
Trace : Ada.Strings.Unbounded.Unbounded_String;
-- Convenient shortcuts.
procedure Raise_With (Message : in String) with Inline, No_Return;
procedure Raise_With (Message : in String) with No_Return;
-- Similar to a "raise with Message" Ada statement.
-- Store the message into Data,
-- store the message and "Uncaught exception: " into Trace,
-- then raise Error.
procedure Raise_In_Mal (E : in Ada.Exceptions.Exception_Occurrence)
with Inline, No_Return;
with No_Return;
-- Raise_With (Ada.Exceptions.Exception_Information (E))
procedure Add_Trace_Line (Action : in String;
Ast : in Types.Mal.T) with Inline;
Ast : in Types.T);
-- Appends a line like "Action: Ast" to Trace.
procedure Check (Condition : in Boolean;
Message : in String) with Inline;
-- Raise_With if Condition fails.
-- It is probably more efficient to construct a boolean and call
-- this procedure once, as "inline" is only a recommendation.
-- Beware of the classical performance issue that the Message is
-- formatted even if the Condition does not hold.
end Err;

11
ada.2/eval_cb.ads
View File

@ -1,11 +0,0 @@
with Envs;
with Types.Mal;
package Eval_Cb is
Cb : access function (Ast : in Types.Mal.T;
Env : in Envs.Ptr) return Types.Mal.T;
-- The main program must register this global callback to the main
-- eval function before some built-in functions are executed.
end Eval_Cb;

14
ada.2/garbage_collected.adb
View File

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

13
ada.2/garbage_collected.ads
View File

@ -1,4 +1,4 @@
package Garbage_Collected with Preelaborate is
package Garbage_Collected is
-- A generic would not be convenient for lists. We want the
-- extended type to be able to have a discriminant.
@ -8,7 +8,8 @@ package Garbage_Collected with Preelaborate is
type Instance is abstract tagged limited private;
subtype Class is Instance'Class;
type Pointer is access all Class;
type Link is access all Class;
subtype Pointer is not null Link;
procedure Keep_References (Object : in out Instance) is null with Inline;
-- A dispatching call in Keep allows subclasses to override this
@ -16,13 +17,13 @@ package Garbage_Collected with Preelaborate is
-- The following methods have no reason to be overridden.
procedure Keep (Object : in out Instance) with Inline;
procedure Keep (Object : in out Class) 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;
procedure Register (Ref : in Pointer) with Inline;
-- Each subclass defines its own allocation pool, but every call
-- to new must be followed by a call to Register.
@ -32,14 +33,14 @@ package Garbage_Collected with Preelaborate is
-- then deallocate the memory for the object.
-- Debug.
procedure Check_Allocations with Inline;
procedure Check_Allocations;
-- Does nothing if assertions are disabled.
private
type Instance is abstract tagged limited record
Kept : Boolean := False;
Next : Pointer := null;
Next : Link := null;
end record;
end Garbage_Collected;

115
ada.2/printer.adb
View File

@ -2,34 +2,36 @@ with Ada.Characters.Latin_1;
with Types.Atoms;
with Types.Fns;
with Types.Sequences;
with Types.Symbols;
with Types.Macros;
with Types.Maps;
pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced");
with Types.Sequences;
pragma Warnings (On, "unit ""Types.Sequences"" is not referenced");
package body Printer is
use Ada.Strings.Unbounded;
use Types;
use all type Types.Kind_Type;
procedure Pr_Str (Buffer : in out Unbounded_String;
Ast : in Mal.T;
Ast : in Types.T;
Readably : in Boolean := True)
is
procedure Print_Form (Form_Ast : in Mal.T);
procedure Print_Form (Form_Ast : in Types.T);
-- The recursive function traversing Ast for Pr_Str.
-- Form_Ast is the current node.
-- Helpers for Print_Form.
procedure Print_Number (Number : in Integer) with Inline;
procedure Print_List (List : in Sequences.Instance) with Inline;
procedure Print_Map (Map : in Maps.Instance) with Inline;
procedure Print_Readably (S : in Unbounded_String) with Inline;
procedure Print_Function (Fn : in Fns.Instance) with Inline;
procedure Print_Number (Number : in Integer);
procedure Print_List (List : in Types.T_Array);
procedure Print_Map (Map : in Types.Maps.Instance);
procedure Print_Readably (S : in String);
procedure Print_String (S : in String);
----------------------------------------------------------------------
procedure Print_Form (Form_Ast : in Mal.T) is
procedure Print_Form (Form_Ast : in Types.T) is
begin
case Form_Ast.Kind is
when Kind_Nil =>
@ -41,27 +43,27 @@ package body Printer is
Append (Buffer, "false");
end if;
when Kind_Symbol =>
Append (Buffer, Symbols.To_String (Form_Ast.Symbol));
Form_Ast.Str.all.Query_Element (Print_String'Access);
when Kind_Number =>
Print_Number (Form_Ast.Number);
when Kind_Keyword =>
Append (Buffer, ':');
Append (Buffer, Form_Ast.S);
Form_Ast.Str.all.Query_Element (Print_String'Access);
when Kind_String =>
if Readably then
Append (Buffer, '"');
Print_Readably (Form_Ast.S);
Form_Ast.Str.all.Query_Element (Print_Readably'Access);
Append (Buffer, '"');
else
Append (Buffer, Form_Ast.S);
Form_Ast.Str.all.Query_Element (Print_String'Access);
end if;
when Kind_List =>
Append (Buffer, '(');
Print_List (Form_Ast.Sequence.all);
Print_List (Form_Ast.Sequence.all.Data);
Append (Buffer, ')');
when Kind_Vector =>
Append (Buffer, '[');
Print_List (Form_Ast.Sequence.all);
Print_List (Form_Ast.Sequence.all.Data);
Append (Buffer, ']');
when Kind_Map =>
Append (Buffer, '{');
@ -71,11 +73,15 @@ package body Printer is
Append (Buffer, "#<built-in>");
when Kind_Fn =>
Append (Buffer, "#<function (");
Print_Function (Form_Ast.Fn.all);
Print_List (Form_Ast.Fn.all.Params.all.Data);
Append (Buffer, ") -> ");
Print_Form (Form_Ast.Fn.all.Ast);
Append (Buffer, '>');
when Kind_Macro =>
Append (Buffer, "#<macro (");
Print_Function (Form_Ast.Fn.all);
Print_List (Form_Ast.Macro.all.Params.all.Data);
Append (Buffer, ") -> ");
Print_Form (Form_Ast.Macro.all.Ast);
Append (Buffer, '>');
when Kind_Atom =>
Append (Buffer, "(atom ");
@ -84,53 +90,31 @@ package body Printer is
end case;
end Print_Form;
procedure Print_Function (Fn : in Fns.Instance) is
Started : Boolean := False;
procedure Print_List (List : in Types.T_Array) is
begin
Append (Buffer, '(');
for Param of Fn.Params loop
if Started then
Append (Buffer, ' ');
else
Started := True;
end if;
Append (Buffer, Symbols.To_String (Param));
end loop;
Append (Buffer, ") -> ");
Print_Form (Fn.Ast);
end Print_Function;
procedure Print_List (List : in Sequences.Instance) is
begin
if 0 < List.Length then
Print_Form (List (1));
for I in 2 .. List.Length loop
if 0 < List'Length then
Print_Form (List (List'First));
for I in List'First + 1 .. List'Last loop
Append (Buffer, ' ');
Print_Form (List (I));
end loop;
end if;
end Print_List;
procedure Print_Map (Map : in Maps.Instance) is
procedure Process (Key : in Mal.T;
Element : in Mal.T) with Inline;
procedure Iterate is new Maps.Iterate (Process);
Started : Boolean := False;
procedure Process (Key : in Mal.T;
Element : in Mal.T)
is
begin
if Started then
Append (Buffer, ' ');
else
Started := True;
end if;
Print_Form (Key);
Append (Buffer, ' ');
Print_Form (Element);
end Process;
procedure Print_Map (Map : in Types.Maps.Instance) is
use all type Types.Maps.Cursor;
Position : Types.Maps.Cursor := Map.First;
begin
Iterate (Map);
if Has_Element (Position) then
loop
Print_Form (Key (Position));
Append (Buffer, ' ');
Print_Form (Element (Position));
Next (Position);
exit when not Has_Element (Position);
Append (Buffer, ' ');
end loop;
end if;
end Print_Map;
procedure Print_Number (Number : in Integer) is
@ -143,12 +127,9 @@ package body Printer is
Append (Buffer, Image (First .. Image'Last));
end Print_Number;
procedure Print_Readably (S : in Unbounded_String) is
procedure Print_Readably (S : in String) is
begin
for I in 1 .. Length (S) loop
declare
C : constant Character := Element (S, I);
begin
for C of S loop
case C is
when '"' | '\' =>
Append (Buffer, '\');
@ -158,17 +139,21 @@ package body Printer is
when others =>
Append (Buffer, C);
end case;
end;
end loop;
end Print_Readably;
procedure Print_String (S : in String) is
begin
Append (Buffer, S);
end Print_String;
----------------------------------------------------------------------
begin -- Pr_Str
Print_Form (Ast);
end Pr_Str;
function Pr_Str (Ast : in Mal.T;
function Pr_Str (Ast : in Types.T;
Readably : in Boolean := True) return Unbounded_String
is
begin

11
ada.2/printer.ads
View File

@ -1,18 +1,19 @@
with Ada.Strings.Unbounded;
with Types.Mal;
with Types;
package Printer with Elaborate_Body is
package Printer is
procedure Pr_Str
(Buffer : in out Ada.Strings.Unbounded.Unbounded_String;
Ast : in Types.Mal.T;
Ast : in Types.T;
Readably : in Boolean := True);
-- Append the text to Buffer.
function Pr_Str (Ast : in Types.Mal.T;
Readably : in Boolean := True)
function Pr_Str (Ast : in Types.T;
Readably : in Boolean := True)
return Ada.Strings.Unbounded.Unbounded_String;
-- Return a freshly created unbounded string.
-- Convenient, but inefficient.
end Printer;

83
ada.2/reader.adb
View File

@ -9,23 +9,23 @@ with Err;
with Printer;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
package body Reader is
Debug : constant Boolean := Ada.Environment_Variables.Exists ("dbgread");
use Types;
use type Ada.Strings.Maps.Character_Set;
use all type Types.Kind_Type;
use all type Ada.Strings.Maps.Character_Set;
Ignored_Set : constant Ada.Strings.Maps.Character_Set
:= Ada.Strings.Maps.Constants.Control_Set
or Ada.Strings.Maps.To_Set (" ,;");
or To_Set (" ,;");
Symbol_Set : constant Ada.Strings.Maps.Character_Set
:= not (Ignored_Set or Ada.Strings.Maps.To_Set ("""'()@[]^`{}~"));
:= not (Ignored_Set or To_Set ("""'()@[]^`{}~"));
function Read_Str (Source : in String) return Types.Mal.T_Array is
function Read_Str (Source : in String) return Types.T_Array is
I : Positive := Source'First;
-- Index in Source of the currently read character.
@ -33,16 +33,16 @@ package body Reader is
-- Big arrays on the stack are faster than repeated dynamic
-- reallocations. This single buffer is used by all Read_List
-- recursive invocations, and by Read_Str.
Buffer : Mal.T_Array (1 .. Source'Length);
Buffer : Types.T_Array (1 .. Source'Length);
B_Last : Natural := Buffer'First - 1;
-- Index in Buffer of the currently written MAL expression.
function Read_Form return Mal.T;
function Read_Form return Types.T;
-- The recursive part of Read_Str.
-- Helpers for Read_Form:
procedure Skip_Ignored with Inline;
procedure Skip_Ignored;
-- Check if the current character is ignorable or a comment.
-- Increment I until it exceeds Source'Last or designates
-- an interesting character.
@ -59,15 +59,15 @@ package body Reader is
-- Read_Atom has been merged into the same case/switch
-- statement, for clarity and efficiency.
function Read_List (Ending : in Character) return Natural with Inline;
function Read_List (Ending : in Character) return Natural;
-- Returns the index of the last elements in Buffer.
-- The elements have been stored in Buffer (B_Last .. result).
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T with Inline;
function Read_Quote (Symbol : in String) return Types.T;
function Read_String return Mal.T with Inline;
function Read_String return Types.T;
function Read_With_Meta return Mal.T with Inline;
function Read_With_Meta return Types.T;
----------------------------------------------------------------------
@ -90,23 +90,22 @@ package body Reader is
return Result;
end Read_List;
function Read_Quote (Symbol : in Symbols.Ptr) return Mal.T is
R : constant Mal.Sequence_Ptr := Sequences.Constructor (2);
function Read_Quote (Symbol : in String) return Types.T is
R : constant Types.Sequence_Ptr := Types.Sequences.Constructor (2);
begin
I := I + 1; -- Skip the initial ' or similar.
R.Replace_Element (1, (Kind_Symbol, Symbol));
R.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc (Symbol));
Skip_Ignored;
Err.Check (I <= Source'Last,
"Incomplete '" & Symbols.To_String (Symbol) & "'");
R.Replace_Element (2, Read_Form);
Err.Check (I <= Source'Last, "Incomplete '" & Symbol & "'");
R.all.Data (2) := Read_Form;
return (Kind_List, R);
end Read_Quote;
function Read_Form return Mal.T is
function Read_Form return Types.T is
-- After I has been increased, current token is be
-- Source (F .. I - 1).
F : Positive;
R : Mal.T; -- The result of this function.
R : Types.T; -- The result of this function.
begin
case Source (I) is
when ')' | ']' | '}' =>
@ -117,8 +116,7 @@ package body Reader is
I := I + 1;
F := I;
Skip_Symbol;
R := (Kind_Keyword, Ada.Strings.Unbounded.To_Unbounded_String
(Source (F .. I - 1)));
R := (Kind_Keyword, Types.Strings.Alloc (Source (F .. I - 1)));
when '-' =>
F := I;
Skip_Digits;
@ -127,45 +125,48 @@ package body Reader is
else
Skip_Symbol;
R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
Types.Strings.Alloc (Source (F .. I - 1)));
end if;
when '~' =>
if I < Source'Last and then Source (I + 1) = '@' then
I := I + 1;
R := Read_Quote (Symbols.Names.Splice_Unquote);
R := Read_Quote ("splice-unquote");
else
R := Read_Quote (Symbols.Names.Unquote);
R := Read_Quote ("unquote");
end if;
when '0' .. '9' =>
F := I;
Skip_Digits;
R := (Kind_Number, Integer'Value (Source (F .. I - 1)));
when ''' =>
R := Read_Quote (Symbols.Names.Quote);
R := Read_Quote ("quote");
when '`' =>
R := Read_Quote (Symbols.Names.Quasiquote);
R := Read_Quote ("quasiquote");
when '@' =>
R := Read_Quote (Symbols.Names.Deref);
R := Read_Quote ("deref");
when '^' =>
R := Read_With_Meta;
when '(' =>
R := Sequences.List (Buffer (B_Last + 1 .. Read_List (')')));
R := Types.Sequences.List
(Buffer (B_Last + 1 .. Read_List (')')));
when '[' =>
R := Sequences.Vector (Buffer (B_Last + 1 .. Read_List (']')));
R := Types.Sequences.Vector
(Buffer (B_Last + 1 .. Read_List (']')));
when '{' =>
R := Maps.Hash_Map (Buffer (B_Last + 1 .. Read_List ('}')));
R := Types.Maps.Hash_Map
(Buffer (B_Last + 1 .. Read_List ('}')));
when others =>
F := I;
Skip_Symbol;
if Source (F .. I - 1) = "false" then
R := (Kind_Boolean, False);
elsif Source (F .. I - 1) = "nil" then
R := Mal.Nil;
R := Types.Nil;
elsif Source (F .. I - 1) = "true" then
R := (Kind_Boolean, True);
else
R := (Kind_Symbol,
Symbols.Constructor (Source (F .. I - 1)));
Types.Strings.Alloc (Source (F .. I - 1)));
end if;
end case;
if Debug then
@ -175,7 +176,7 @@ package body Reader is
return R;
end Read_Form;
function Read_String return Mal.T is
function Read_String return Types.T is
use Ada.Strings.Unbounded;
Result : Unbounded_String;
begin
@ -201,18 +202,18 @@ package body Reader is
end case;
end loop;
I := I + 1; -- Skip closing double quote.
return (Kind_String, Result);
return (Kind_String, Types.Strings.Alloc (To_String (Result)));
end Read_String;
function Read_With_Meta return Mal.T is
List : constant Mal.Sequence_Ptr := Sequences.Constructor (3);
function Read_With_Meta return Types.T is
List : constant Types.Sequence_Ptr := Types.Sequences.Constructor (3);
begin
I := I + 1; -- Skip the initial ^.
List.all.Replace_Element (1, (Kind_Symbol, Symbols.Names.With_Meta));
List.all.Data (1) := (Kind_Symbol, Types.Strings.Alloc ("with-meta"));
for I in reverse 2 .. 3 loop
Skip_Ignored;
Err.Check (I <= Source'Last, "Incomplete 'with-meta'");
List.all.Replace_Element (I, Read_Form);
List.all.Data (I) := Read_Form;
end loop;
return (Kind_List, List);
end Read_With_Meta;
@ -229,7 +230,6 @@ package body Reader is
procedure Skip_Ignored is
use Ada.Characters.Handling;
use Ada.Strings.Maps;
begin
Ignored : while I <= Source'Last
and then Is_In (Source (I), Ignored_Set)
@ -246,7 +246,6 @@ package body Reader is
end Skip_Ignored;
procedure Skip_Symbol is
use Ada.Strings.Maps;
begin
while I <= Source'Last and then Is_In (Source (I), Symbol_Set) loop
I := I + 1;

6
ada.2/reader.ads
View File

@ -1,8 +1,8 @@
with Types.Mal;
with Types;
package Reader with Elaborate_Body is
package Reader is
function Read_Str (Source : in String) return Types.Mal.T_Array;
function Read_Str (Source : in String) return Types.T_Array;
-- The language does not explicitly define what happens when the
-- input string contains more than one expression.
-- This implementation returns all of them.

2
ada.2/readline.ads
View File

@ -1,4 +1,4 @@
package Readline with Preelaborate is
package Readline is
function Input (Prompt : in String) return String;

4
ada.2/step0_repl.adb
View File

@ -14,7 +14,8 @@ procedure Step0_Repl is
----------------------------------------------------------------------
function Eval (Ast : in String) return String is (Ast);
function Eval (Ast : in String) return String
is (Ast);
procedure Print (Ast : in String) is
begin
@ -38,6 +39,7 @@ begin
when Readline.End_Of_File =>
exit;
end;
-- Other exceptions are really unexpected.
end loop;
Ada.Text_IO.New_Line;
end Step0_Repl;

24
ada.2/step1_read_print.adb
View File

@ -5,31 +5,28 @@ with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Mal;
with Types.Symbols;
with Types;
procedure Step1_Read_Print is
use Types;
function Read return Types.T_Array with Inline;
function Read return Mal.T_Array with Inline;
function Eval (Ast : in Types.T) return Types.T;
function Eval (Ast : in Mal.T) return Mal.T;
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep with Inline;
----------------------------------------------------------------------
function Eval (Ast : in Mal.T) return Mal.T is (Ast);
function Eval (Ast : in Types.T) return Types.T is (Ast);
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep is
@ -54,12 +51,15 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
-- No data survives at this stage, Repl only contains static
-- pointers to built-in functions.
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step1_Read_Print;

117
ada.2/step2_eval.adb
View File

@ -8,45 +8,49 @@ with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols;
with Types.Strings;
procedure Step2_Eval is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Types.T;
use all type Types.Kind_Type;
package Envs is new Ada.Containers.Indefinite_Hashed_Maps
(Key_Type => String,
Element_Type => Mal.Builtin_Ptr,
Element_Type => Types.Builtin_Ptr,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=",
"=" => Mal."=");
"=" => Types."=");
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast : in Mal.T;
Env : in Envs.Map) return Mal.T;
function Eval (Ast : in Types.T;
Env : in Envs.Map) return Types.T;
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Map) with Inline;
generic
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 Types.T_Array) return Types.T;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Map, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Map) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Map) return Types.T;
-- Helpers for the Eval function.
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Envs.Map) return Mal.T
function Eval (Ast : in Types.T;
Env : in Envs.Map) return Types.T
is
First : Mal.T;
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
@ -55,12 +59,12 @@ procedure Step2_Eval is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
declare
S : constant String := Ast.Symbol.To_String;
S : constant String := Ast.Str.all.To_String;
C : constant Envs.Cursor := Env.Find (S);
begin
-- The predefined error message does not pass tests.
@ -68,17 +72,9 @@ procedure Step2_Eval is
return (Kind_Builtin, Envs.Element (C));
end;
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -87,7 +83,7 @@ procedure Step2_Eval is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Ast is a non-empty list, First is its first element.
First := Eval (First, Env);
@ -95,35 +91,61 @@ procedure Step2_Eval is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind = Kind_Builtin,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
return First.Builtin.all (Args);
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Map) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Map) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T
is (Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Map) is
@ -158,13 +180,16 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
-- No data survives at this stage, Repl only contains static
-- pointers to built-in functions.
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step2_Eval;

166
ada.2/step3_env.adb
View File

@ -7,39 +7,43 @@ with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step3_Env is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Eval (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
generic
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 Types.T_Array) return Types.T;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Eval (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
First : Mal.T;
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
@ -49,23 +53,15 @@ procedure Step3_Env is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -74,38 +70,37 @@ procedure Step3_Env is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
if First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
New_Env : Envs.Ptr;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
New_Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), New_Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
for I in 0 .. Bindings'Length / 2 - 1 loop
New_Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), New_Env));
-- This call checks key kind.
end loop;
return Eval (Ast.Sequence.all (3), New_Env);
return Eval (Ast.Sequence.all.Data (3), New_Env);
end;
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
else
First := Eval (First, Env);
@ -117,35 +112,61 @@ procedure Step3_Env is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind = Kind_Builtin,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
return First.Builtin.all (Args);
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Generic_Mal_Operator (Args : in Mal.T_Array) return Mal.T
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
function Generic_Mal_Operator (Args : in Types.T_Array) return Types.T
is (Kind_Number, Ada_Operator (Args (Args'First).Number,
Args (Args'Last).Number));
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -165,13 +186,13 @@ procedure Step3_Env is
Repl : constant Envs.Ptr := Envs.New_Env;
begin
-- Add Core functions into the top environment.
Repl.all.Set (Symbols.Constructor ("+"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("+")),
(Kind_Builtin, Addition 'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("-"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("-")),
(Kind_Builtin, Subtraction'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("*"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*")),
(Kind_Builtin, Product 'Unrestricted_Access));
Repl.all.Set (Symbols.Constructor ("/"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("/")),
(Kind_Builtin, Division 'Unrestricted_Access));
-- Execute user commands.
loop
@ -186,14 +207,15 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step3_Env;

206
ada.2/step4_if_fn_do.adb
View File

@ -4,34 +4,37 @@ with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step4_If_Fn_Do is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Eval (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -39,11 +42,10 @@ procedure Step4_If_Fn_Do is
----------------------------------------------------------------------
function Eval (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Eval (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
First : Mal.T;
First : Types.T;
begin
if Dbgeval then
Ada.Text_IO.New_Line;
@ -53,23 +55,15 @@ procedure Step4_If_Fn_Do is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -78,61 +72,64 @@ procedure Step4_If_Fn_Do is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
return Eval (Ast.Sequence.all (3), Env);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
return Eval (Ast.Sequence.all.Data (3), Env);
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
return Eval (Ast.Sequence.all (4), Env);
return Eval (Ast.Sequence.all.Data (4), Env);
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
New_Env : Envs.Ptr;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
New_Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
New_Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), New_Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
for I in 0 .. Bindings'Length / 2 - 1 loop
New_Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), New_Env));
-- This call checks key kind.
end loop;
return Eval (Ast.Sequence.all (3), New_Env);
return Eval (Ast.Sequence.all.Data (3), New_Env);
end;
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
else
First := Eval (First, Env);
@ -144,38 +141,58 @@ procedure Step4_If_Fn_Do is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Fn.all.Apply (Args);
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind in Types.Kind_Function,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
return First.Fn.all.Apply (Args);
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -183,12 +200,12 @@ procedure Step4_If_Fn_Do is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -205,7 +222,7 @@ procedure Step4_If_Fn_Do is
Repl : constant Envs.Ptr := Envs.New_Env;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
-- Native startup procedure.
@ -223,14 +240,15 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step4_If_Fn_Do;

233
ada.2/step5_tco.adb
View File

@ -4,34 +4,37 @@ with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step5_Tco is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -39,15 +42,18 @@ procedure Step5_Tco is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
First : Mal.T;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -58,23 +64,15 @@ procedure Step5_Tco is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -83,75 +81,83 @@ procedure Step5_Tco is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -160,42 +166,64 @@ procedure Step5_Tco is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind in Types.Kind_Function,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -203,12 +231,12 @@ procedure Step5_Tco is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -225,7 +253,7 @@ procedure Step5_Tco is
Repl : constant Envs.Ptr := Envs.New_Env;
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
-- Native startup procedure.
@ -243,14 +271,15 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
Ada.Text_IO.New_Line;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step5_Tco;

262
ada.2/step6_file.adb
View File

@ -1,43 +1,44 @@
with Ada.Command_Line;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step6_File is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
function Eval_Builtin (Args : in Types.T_Array) return Types.T;
-- The built-in variant needs to see the Repl variable.
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -45,15 +46,18 @@ procedure Step6_File is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
First : Mal.T;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -64,23 +68,15 @@ procedure Step6_File is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -89,75 +85,83 @@ procedure Step6_File is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -166,42 +170,64 @@ procedure Step6_File is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind in Types.Kind_Function,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -209,12 +235,12 @@ procedure Step6_File is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -231,33 +257,30 @@ procedure Step6_File is
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
function Eval_Builtin (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
return Eval (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
Argv : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
for I in 2 .. ACL.Argument_Count loop
Argv.all.Data (I - 1) := (Kind_String,
Types.Strings.Alloc (ACL.Argument (I)));
end loop;
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
(Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
@ -274,7 +297,7 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
@ -282,7 +305,8 @@ begin
end if;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step6_File;

334
ada.2/step7_quote.adb
View File

@ -1,51 +1,53 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step7_Quote is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
function Eval_Builtin (Args : in Types.T_Array) return Types.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -53,15 +55,18 @@ procedure Step7_Quote is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
First : Mal.T;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -72,23 +77,15 @@ procedure Step7_Quote is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -97,81 +94,89 @@ procedure Step7_Quote is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Quasiquote then
elsif First.Str.all = "quote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
return Ast.Sequence.all.Data (2);
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
return Quasiquote (Ast.Sequence.all.Data (2), Env);
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -180,42 +185,64 @@ procedure Step7_Quote is
-- Apply phase.
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
when others =>
Err.Raise_With ("first element must be a function");
end case;
Err.Check (First.Kind in Types.Kind_Function,
"first element must be a function");
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
Err.Add_Trace_Line ("eval", Ast);
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -223,65 +250,66 @@ procedure Step7_Quote is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
function Quasiquote_List (List : in Types.T_Array) return Types.T;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
function Quasiquote_List (List : in Types.T_Array) return Types.T is
Vector : Vectors.Vector; -- buffer for concatenation
Tmp : Types.T;
begin
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
for Elt of List loop
if Elt.Kind in Kind_List
and then 0 < Elt.Sequence.all.Length
and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
then
Err.Check (List (I).Sequence.all.Length = 2,
Err.Check (Elt.Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
Tmp := Eval (List (I).Sequence.all (2), Env);
Tmp := Eval (Elt.Sequence.all.Data (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
for Sub_Elt of Tmp.Sequence.all.Data loop
Vector.Append (Sub_Elt);
end loop;
else
Vector.Append (Quasiquote (List (I), Env));
Vector.Append (Quasiquote (Elt, Env));
end if;
end loop;
-- 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);
declare
Sequence : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Natural (Vector.Length));
begin
for I in 1 .. Natural (Vector.Length) loop
Sequence.all.Data (I) := Vector (I);
end loop;
return (Kind_List, Sequence);
end;
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
when Kind_List =>
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
and then Ast.Sequence.all.Data (1).Str.all = "unquote"
then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
else
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
end if;
when others =>
return Ast;
@ -292,7 +320,7 @@ procedure Step7_Quote is
raise;
end Quasiquote;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -309,33 +337,30 @@ procedure Step7_Quote is
& "(def! load-file (fn* (f)"
& " (eval (read-string (str ""(do "" (slurp f) "")"")))))";
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
function Eval_Builtin (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
return Eval (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
Argv : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
for I in 2 .. ACL.Argument_Count loop
Argv.all.Data (I - 1) := (Kind_String,
Types.Strings.Alloc (ACL.Argument (I)));
end loop;
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
(Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
@ -352,7 +377,7 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
@ -360,7 +385,8 @@ begin
end if;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step7_Quote;

406
ada.2/step8_macros.adb
View File

@ -1,51 +1,54 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Macros;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step8_Macros is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
function Eval_Builtin (Args : in Types.T_Array) return Types.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -53,16 +56,19 @@ procedure Step8_Macros is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Mal.T;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -73,23 +79,15 @@ procedure Step8_Macros is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -98,98 +96,106 @@ procedure Step8_Macros is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
elsif First.Str.all = "quote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all.Data (2);
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
elsif First.Str.all = "defmacro!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
Val : Types.T;
begin
Err.Check (Fun.Kind = Kind_Fn, "expected a function");
Val := Types.Macros.New_Macro (Fun.Fn.all);
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all (2);
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
return Quasiquote (Ast.Sequence.all.Data (2), Env);
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -199,53 +205,56 @@ procedure Step8_Macros is
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Macro.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
New_Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data
(2 .. Ast.Sequence.all.Length));
Ast := Eval (First.Macro.all.Ast, New_Env);
-- Then evaluate the result with TCO.
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
end;
when others =>
Err.Raise_With ("first element must be a function or macro");
end if;
when Types.Kind_Function =>
null;
when others =>
Err.Raise_With ("first element must be a function or macro");
end case;
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
if Macroexpanding then
@ -256,10 +265,38 @@ procedure Step8_Macros is
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -267,65 +304,66 @@ procedure Step8_Macros is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
function Quasiquote_List (List : in Types.T_Array) return Types.T;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
function Quasiquote_List (List : in Types.T_Array) return Types.T is
Vector : Vectors.Vector; -- buffer for concatenation
Tmp : Types.T;
begin
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
for Elt of List loop
if Elt.Kind in Kind_List
and then 0 < Elt.Sequence.all.Length
and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
then
Err.Check (List (I).Sequence.all.Length = 2,
Err.Check (Elt.Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
Tmp := Eval (List (I).Sequence.all (2), Env);
Tmp := Eval (Elt.Sequence.all.Data (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
for Sub_Elt of Tmp.Sequence.all.Data loop
Vector.Append (Sub_Elt);
end loop;
else
Vector.Append (Quasiquote (List (I), Env));
Vector.Append (Quasiquote (Elt, Env));
end if;
end loop;
-- 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);
declare
Sequence : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Natural (Vector.Length));
begin
for I in 1 .. Natural (Vector.Length) loop
Sequence.all.Data (I) := Vector (I);
end loop;
return (Kind_List, Sequence);
end;
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
when Kind_List =>
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
and then Ast.Sequence.all.Data (1).Str.all = "unquote"
then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
else
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
end if;
when others =>
return Ast;
@ -336,7 +374,7 @@ procedure Step8_Macros is
raise;
end Quasiquote;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -364,33 +402,30 @@ procedure Step8_Macros is
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
function Eval_Builtin (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
return Eval (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
Argv : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
for I in 2 .. ACL.Argument_Count loop
Argv.all.Data (I - 1) := (Kind_String,
Types.Strings.Alloc (ACL.Argument (I)));
end loop;
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
(Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
@ -407,7 +442,7 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
@ -415,7 +450,8 @@ begin
end if;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step8_Macros;

441
ada.2/step9_try.adb
View File

@ -1,51 +1,54 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Fns;
with Types.Mal;
with Types.Macros;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure Step9_Try is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
function Eval_Builtin (Args : in Types.T_Array) return Types.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -53,16 +56,19 @@ procedure Step9_Try is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Mal.T;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -73,23 +79,15 @@ procedure Step9_Try is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -98,127 +96,136 @@ procedure Step9_Try is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
elsif First.Str.all = "quote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all.Data (2);
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
elsif First.Str.all = "defmacro!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
Val : Types.T;
begin
Err.Check (Fun.Kind = Kind_Fn, "expected a function");
Val := Types.Macros.New_Macro (Fun.Fn.all);
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all (2);
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
elsif First.Symbol = Symbols.Names.Try then
return Quasiquote (Ast.Sequence.all.Data (2), Env);
elsif First.Str.all = "try*" then
if Ast.Sequence.all.Length = 2 then
Ast := Ast.Sequence.all (2);
Ast := Ast.Sequence.all.Data (2);
goto Restart;
end if;
Err.Check (Ast.Sequence.all.Length = 3,
"expected 1 or 2 parameters");
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
"parameter 2 must be a list");
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (3).Kind = Kind_List,
"expected 1 parameter, maybe followed by a list");
declare
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
A3 : Types.T_Array
renames Ast.Sequence.all.Data (3).Sequence.all.Data;
begin
Err.Check (A3.all.Length = 3,
"length of parameter 2 must be 3");
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
"parameter 3 must start with 'catch*'");
Err.Check (A3.all (2).Kind = Kind_Symbol,
"a symbol must follow catch*");
Err.Check (A3'Length = 3
and then A3 (A3'First).Kind = Kind_Symbol
and then A3 (A3'First).Str.all = "catch*",
"3rd parameter if present must be a catch* list");
begin
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
exception
when Err.Error =>
null;
end;
Env := Envs.New_Env (Outer => Env);
Env.all.Set (A3.all (2).Symbol, Err.Data);
Ast := A3.all (3);
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind
Ast := A3 (A3'Last);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -228,53 +235,56 @@ procedure Step9_Try is
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Macro.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
New_Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data
(2 .. Ast.Sequence.all.Length));
Ast := Eval (First.Macro.all.Ast, New_Env);
-- Then evaluate the result with TCO.
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
end;
when others =>
Err.Raise_With ("first element must be a function or macro");
end if;
when Types.Kind_Function =>
null;
when others =>
Err.Raise_With ("first element must be a function or macro");
end case;
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
if First.Kind = Kind_Builtin then
return First.Builtin.all (Args);
end if;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
if Macroexpanding then
@ -285,10 +295,38 @@ procedure Step9_Try is
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -296,65 +334,66 @@ procedure Step9_Try is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
function Quasiquote_List (List : in Types.T_Array) return Types.T;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
function Quasiquote_List (List : in Types.T_Array) return Types.T is
Vector : Vectors.Vector; -- buffer for concatenation
Tmp : Types.T;
begin
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
for Elt of List loop
if Elt.Kind in Kind_List
and then 0 < Elt.Sequence.all.Length
and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
then
Err.Check (List (I).Sequence.all.Length = 2,
Err.Check (Elt.Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
Tmp := Eval (List (I).Sequence.all (2), Env);
Tmp := Eval (Elt.Sequence.all.Data (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
for Sub_Elt of Tmp.Sequence.all.Data loop
Vector.Append (Sub_Elt);
end loop;
else
Vector.Append (Quasiquote (List (I), Env));
Vector.Append (Quasiquote (Elt, Env));
end if;
end loop;
-- 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);
declare
Sequence : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Natural (Vector.Length));
begin
for I in 1 .. Natural (Vector.Length) loop
Sequence.all.Data (I) := Vector (I);
end loop;
return (Kind_List, Sequence);
end;
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
when Kind_List =>
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
and then Ast.Sequence.all.Data (1).Str.all = "unquote"
then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
else
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
end if;
when others =>
return Ast;
@ -365,7 +404,7 @@ procedure Step9_Try is
raise;
end Quasiquote;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -393,33 +432,30 @@ procedure Step9_Try is
& " `(let* (or_FIXME ~(first xs))"
& " (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
function Eval_Builtin (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
return Eval (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
Argv : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
for I in 2 .. ACL.Argument_Count loop
Argv.all.Data (I - 1) := (Kind_String,
Types.Strings.Alloc (ACL.Argument (I)));
end loop;
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
(Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
@ -436,7 +472,7 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
@ -444,7 +480,8 @@ begin
end if;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end Step9_Try;

455
ada.2/stepa_mal.adb
View File

@ -1,52 +1,55 @@
with Ada.Command_Line;
with Ada.Containers.Vectors;
with Ada.Environment_Variables;
with Ada.Strings.Unbounded;
with Ada.Text_IO.Unbounded_IO;
with Core;
with Envs;
with Err;
with Eval_Cb;
with Garbage_Collected;
with Printer;
with Reader;
with Readline;
with Types.Builtins;
with Types.Fns;
with Types.Mal;
with Types.Macros;
with Types.Maps;
with Types.Sequences;
with Types.Symbols.Names;
with Types.Strings;
procedure StepA_Mal is
Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
use Types;
use type Mal.T;
use type Types.T;
use all type Types.Kind_Type;
use type Types.Strings.Instance;
package ACL renames Ada.Command_Line;
package ASU renames Ada.Strings.Unbounded;
package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
function Read return Mal.T_Array with Inline;
function Read return Types.T_Array with Inline;
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T;
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T;
function Eval_Builtin (Args : in Types.T_Array) return Types.T;
-- The built-in variant needs to see the Repl variable.
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T;
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T;
-- Mergeing quote and quasiquote into eval with a flag triggering
-- a different behaviour as done for macros in step8 would improve
-- the performances significantly, but Kanaka finds that it breaks
-- too much the step structure shared by all implementations.
procedure Print (Ast : in Mal.T) with Inline;
procedure Print (Ast : in Types.T) with Inline;
procedure Rep (Env : in Envs.Ptr) with Inline;
function Eval_Map_Elts is new Maps.Generic_Eval (Envs.Ptr, Eval);
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T;
-- Helpers for the Eval function.
procedure Exec (Script : in String;
Env : in Envs.Ptr) with Inline;
@ -54,16 +57,19 @@ procedure StepA_Mal is
----------------------------------------------------------------------
function Eval (Ast0 : in Mal.T;
Env0 : in Envs.Ptr) return Mal.T
function Eval (Ast0 : in Types.T;
Env0 : in Envs.Ptr) return Types.T
is
use type Symbols.Ptr;
-- Use local variables, that can be rewritten when tail call
-- optimization goes to <<Restart>>.
Ast : Mal.T := Ast0;
Ast : Types.T := Ast0;
Env : Envs.Ptr := Env0;
Env_Reusable : Boolean := False;
-- True when the environment has been created in this recursion
-- level, and has not yet been referenced by a closure. If so,
-- we can reuse it instead of creating a subenvironment.
Macroexpanding : Boolean := False;
First : Mal.T;
First : Types.T;
begin
<<Restart>>
if Dbgeval then
@ -74,23 +80,15 @@ procedure StepA_Mal is
end if;
case Ast.Kind is
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
return Ast;
when Kind_Symbol =>
return Env.all.Get (Ast.Symbol);
return Env.all.Get (Ast.Str);
when Kind_Map =>
return Eval_Map_Elts (Ast.Map.all, Env);
return Eval_Map (Ast.Map.all, Env);
when Kind_Vector =>
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;
return Eval_Vector (Ast.Sequence.all, Env);
when Kind_List =>
null;
end case;
@ -99,127 +97,136 @@ procedure StepA_Mal is
if Ast.Sequence.all.Length = 0 then
return Ast;
end if;
First := Ast.Sequence.all (1);
First := Ast.Sequence.all.Data (1);
-- Special forms
-- Ast is a non-empty list, First is its first element.
case First.Kind is
when Kind_Symbol =>
if First.Symbol = Symbols.Names.Def then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
return R : constant Mal.T := Eval (Ast.Sequence.all (3), Env) do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
elsif First.Symbol = Symbols.Names.Defmacro then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind = Kind_Symbol,
"parameter 1 must be a symbol");
declare
F : constant Mal.T := Eval (Ast.Sequence.all (3), Env);
begin
Err.Check (F.Kind = Kind_Fn, "parameter 2 must be a function");
return R : constant Mal.T := F.Fn.all.New_Macro do
Env.all.Set (Ast.Sequence.all (2).Symbol, R);
end return;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Symbol = Symbols.Names.Fn then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
return Fns.New_Function
(Params => Ast.Sequence.all (2).Sequence.all,
Ast => Ast.Sequence.all (3),
Env => Env);
elsif First.Symbol = Symbols.Names.Mal_If then
if First.Str.all = "if" then
Err.Check (Ast.Sequence.all.Length in 3 .. 4,
"expected 2 or 3 parameters");
declare
Test : constant Mal.T := Eval (Ast.Sequence.all (2), Env);
Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
begin
if Test /= Mal.Nil and Test /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all (3);
if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
Ast := Ast.Sequence.all.Data (3);
goto Restart;
elsif Ast.Sequence.all.Length = 3 then
return Mal.Nil;
return Types.Nil;
else
Ast := Ast.Sequence.all (4);
Ast := Ast.Sequence.all.Data (4);
goto Restart;
end if;
end;
elsif First.Symbol = Symbols.Names.Let then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
Err.Check (Ast.Sequence.all (2).Kind in Kind_Sequence,
"parameter 1 must be a sequence");
elsif First.Str.all = "let*" then
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
"expected a sequence then a value");
declare
Bindings : constant Mal.Sequence_Ptr
:= Ast.Sequence.all (2).Sequence;
Bindings : Types.T_Array
renames Ast.Sequence.all.Data (2).Sequence.all.Data;
begin
Err.Check (Bindings.all.Length mod 2 = 0,
"parameter 1 must have an even length");
Env := Envs.New_Env (Outer => Env);
for I in 1 .. Bindings.all.Length / 2 loop
Err.Check (Bindings.all (2 * I - 1).Kind = Kind_Symbol,
"binding keys must be symbols");
Env.all.Set (Bindings.all (2 * I - 1).Symbol,
Eval (Bindings.all (2 * I), Env));
Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
for I in 0 .. Bindings'Length / 2 - 1 loop
Env.all.Set (Bindings (Bindings'First + 2 * I),
Eval (Bindings (Bindings'First + 2 * I + 1), Env));
-- This call checks key kind.
end loop;
Ast := Ast.Sequence.all (3);
Ast := Ast.Sequence.all.Data (3);
goto Restart;
end;
elsif First.Symbol = Symbols.Names.Macroexpand then
elsif First.Str.all = "quote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all.Data (2);
elsif First.Str.all = "def!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
begin
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
elsif First.Str.all = "defmacro!" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Key : Types.T renames Ast.Sequence.all.Data (2);
Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
Val : Types.T;
begin
Err.Check (Fun.Kind = Kind_Fn, "expected a function");
Val := Types.Macros.New_Macro (Fun.Fn.all);
Env.all.Set (Key, Val); -- Check key kind.
return Val;
end;
-- do is a built-in function, shortening this test cascade.
elsif First.Str.all = "fn*" then
Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
declare
Params : Types.T renames Ast.Sequence.all.Data (2);
begin
Err.Check (Params.Kind in Types.Kind_Sequence,
"first argument of fn* must be a sequence");
Env_Reusable := False;
return Types.Fns.New_Function
(Params => Params.Sequence,
Ast => Ast.Sequence.all.Data (3),
Env => Env);
end;
elsif First.Str.all = "macroexpand" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
Macroexpanding := True;
Ast := Ast.Sequence.all (2);
Ast := Ast.Sequence.all.Data (2);
goto Restart;
elsif First.Symbol = Symbols.Names.Quasiquote then
elsif First.Str.all = "quasiquote" then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Quasiquote (Ast.Sequence.all (2), Env);
elsif First.Symbol = Symbols.Names.Quote then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Ast.Sequence.all (2);
elsif First.Symbol = Symbols.Names.Try then
return Quasiquote (Ast.Sequence.all.Data (2), Env);
elsif First.Str.all = "try*" then
if Ast.Sequence.all.Length = 2 then
Ast := Ast.Sequence.all (2);
Ast := Ast.Sequence.all.Data (2);
goto Restart;
end if;
Err.Check (Ast.Sequence.all.Length = 3,
"expected 1 or 2 parameters");
Err.Check (Ast.Sequence.all (3).Kind = Kind_List,
"parameter 2 must be a list");
Err.Check (Ast.Sequence.all.Length = 3
and then Ast.Sequence.all.Data (3).Kind = Kind_List,
"expected 1 parameter, maybe followed by a list");
declare
A3 : constant Mal.Sequence_Ptr := Ast.Sequence.all (3).Sequence;
A3 : Types.T_Array
renames Ast.Sequence.all.Data (3).Sequence.all.Data;
begin
Err.Check (A3.all.Length = 3,
"length of parameter 2 must be 3");
Err.Check (A3.all (1) = (Kind_Symbol, Symbols.Names.Catch),
"parameter 3 must start with 'catch*'");
Err.Check (A3.all (2).Kind = Kind_Symbol,
"a symbol must follow catch*");
Err.Check (A3'Length = 3
and then A3 (A3'First).Kind = Kind_Symbol
and then A3 (A3'First).Str.all = "catch*",
"3rd parameter if present must be a catch* list");
begin
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
exception
when Err.Error =>
null;
end;
Env := Envs.New_Env (Outer => Env);
Env.all.Set (A3.all (2).Symbol, Err.Data);
Ast := A3.all (3);
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
Env.all.Set (A3 (A3'First + 1), Err.Data); -- check key kind
Ast := A3 (A3'Last);
goto Restart;
end;
else
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
First := Env.all.Get (First.Symbol);
First := Env.all.Get (First.Str);
end if;
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Kind_Key
| Kind_Macro | Kind_Function =>
when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
| Kind_Macro | Types.Kind_Function =>
-- Equivalent to First := Eval (First, Env)
-- except that we already know enough to spare a recursive call.
null;
when Kind_Sequence | Kind_Map =>
when Types.Kind_Sequence | Kind_Map =>
-- Lists are definitely worth a recursion, and the two other
-- cases should be rare (they will report an error later).
First := Eval (First, Env);
@ -229,62 +236,61 @@ procedure StepA_Mal is
-- Ast is a non-empty list,
-- First is its non-special evaluated first element.
case First.Kind is
when Kind_Builtin =>
when Kind_Macro =>
-- Use the unevaluated arguments.
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
if not Env_Reusable then
Env := Envs.New_Env (Outer => Env);
Env_Reusable := True;
end if;
Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
Ast := First.Macro.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin.all (Args);
end;
when Kind_Builtin_With_Meta =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
return First.Builtin_With_Meta.all.Builtin.all (Args);
end;
when Kind_Fn =>
declare
Args : Mal.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all (I), Env);
end loop;
Env := Envs.New_Env (Outer => First.Fn.all.Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
New_Env.all.Set_Binds
(Binds => First.Macro.all.Params.all.Data,
Exprs => Ast.Sequence.all.Data
(2 .. Ast.Sequence.all.Length));
Ast := Eval (First.Macro.all.Ast, New_Env);
-- Then evaluate the result with TCO.
goto Restart;
end;
when Kind_Macro =>
declare
Args : constant Mal.T_Array
:= Ast.Sequence.all.Tail (Ast.Sequence.all.Length - 1);
begin
if Macroexpanding then
-- Evaluate the macro with tail call optimization.
Env := Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
else
-- Evaluate the macro normally.
Ast := Eval (First.Fn.all.Ast,
Envs.New_Env (Outer => Env,
Binds => First.Fn.all.Params,
Exprs => Args));
-- Then evaluate the result with TCO.
goto Restart;
end if;
end;
when others =>
Err.Raise_With ("first element must be a function or macro");
end if;
when Types.Kind_Function =>
null;
when others =>
Err.Raise_With ("first element must be a function or macro");
end case;
-- We are applying a function. Evaluate its arguments.
declare
Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
begin
for I in Args'Range loop
Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
end loop;
case First.Kind is
when Kind_Builtin =>
return First.Builtin.all (Args);
when Kind_Builtin_With_Meta =>
return First.Builtin_With_Meta.all.Builtin.all (Args);
when others =>
null;
end case;
-- Like Types.Fns.Apply, except that we use TCO.
Env := Envs.New_Env (Outer => First.Fn.all.Env);
Env_Reusable := True;
Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
Exprs => Args);
Ast := First.Fn.all.Ast;
goto Restart;
end;
exception
when Err.Error =>
if Macroexpanding then
@ -295,10 +301,38 @@ procedure StepA_Mal is
raise;
end Eval;
function Eval_Map (Source : in Types.Maps.Instance;
Env : in Envs.Ptr) return Types.T
is
use all type Types.Maps.Cursor;
-- Copy the whole map so that keys are not hashed again.
Result : constant Types.T := Types.Maps.New_Map (Source);
Position : Types.Maps.Cursor := Result.Map.all.First;
begin
while Has_Element (Position) loop
Result.Map.all.Replace_Element (Position,
Eval (Element (Position), Env));
Next (Position);
end loop;
return Result;
end Eval_Map;
function Eval_Vector (Source : in Types.Sequences.Instance;
Env : in Envs.Ptr) return Types.T
is
Ref : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Source.Length);
begin
for I in Source.Data'Range loop
Ref.all.Data (I) := Eval (Source.Data (I), Env);
end loop;
return (Kind_Vector, Ref);
end Eval_Vector;
procedure Exec (Script : in String;
Env : in Envs.Ptr)
is
Result : Mal.T;
Result : Types.T;
begin
for Expression of Reader.Read_Str (Script) loop
Result := Eval (Expression, Env);
@ -306,65 +340,66 @@ procedure StepA_Mal is
pragma Unreferenced (Result);
end Exec;
procedure Print (Ast : in Mal.T) is
procedure Print (Ast : in Types.T) is
begin
Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
end Print;
function Quasiquote (Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
function Quasiquote (Ast : in Types.T;
Env : in Envs.Ptr) return Types.T
is
function Quasiquote_List (List : in Sequences.Instance) return Mal.T
with Inline;
function Quasiquote_List (List : in Types.T_Array) return Types.T;
-- Handle vectors and lists not starting with unquote.
function Quasiquote_List (List : in Sequences.Instance) return Mal.T is
package Vectors is new Ada.Containers.Vectors (Positive, Mal.T);
Vector : Vectors.Vector; -- buffer for concatenation
Sequence : Mal.Sequence_Ptr;
Tmp : Mal.T;
function Quasiquote_List (List : in Types.T_Array) return Types.T is
Vector : Vectors.Vector; -- buffer for concatenation
Tmp : Types.T;
begin
for I in 1 .. List.Length loop
if List (I).Kind in Kind_List
and then 0 < List (I).Sequence.all.Length
and then List (I).Sequence.all (1)
= (Kind_Symbol, Symbols.Names.Splice_Unquote)
for Elt of List loop
if Elt.Kind in Kind_List
and then 0 < Elt.Sequence.all.Length
and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
then
Err.Check (List (I).Sequence.all.Length = 2,
Err.Check (Elt.Sequence.all.Length = 2,
"splice-unquote expects 1 parameter");
Tmp := Eval (List (I).Sequence.all (2), Env);
Tmp := Eval (Elt.Sequence.all.Data (2), Env);
Err.Check (Tmp.Kind = Kind_List,
"splice_unquote expects a list");
for I in 1 .. Tmp.Sequence.all.Length loop
Vector.Append (Tmp.Sequence.all (I));
for Sub_Elt of Tmp.Sequence.all.Data loop
Vector.Append (Sub_Elt);
end loop;
else
Vector.Append (Quasiquote (List (I), Env));
Vector.Append (Quasiquote (Elt, Env));
end if;
end loop;
-- 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);
declare
Sequence : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Natural (Vector.Length));
begin
for I in 1 .. Natural (Vector.Length) loop
Sequence.all.Data (I) := Vector (I);
end loop;
return (Kind_List, Sequence);
end;
end Quasiquote_List;
begin -- Quasiquote
case Ast.Kind is
when Kind_Vector =>
-- When the test is updated, replace Kind_List with Kind_Vector.
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
when Kind_List =>
if 0 < Ast.Sequence.all.Length
and then Ast.Sequence.all (1) = (Kind_Symbol,
Symbols.Names.Unquote)
and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
and then Ast.Sequence.all.Data (1).Str.all = "unquote"
then
Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
return Eval (Ast.Sequence.all (2), Env);
return Eval (Ast.Sequence.all.Data (2), Env);
else
return Quasiquote_List (Ast.Sequence.all);
return Quasiquote_List (Ast.Sequence.all.Data);
end if;
when others =>
return Ast;
@ -375,7 +410,7 @@ procedure StepA_Mal is
raise;
end Quasiquote;
function Read return Mal.T_Array
function Read return Types.T_Array
is (Reader.Read_Str (Readline.Input ("user> ")));
procedure Rep (Env : in Envs.Ptr) is
@ -408,33 +443,30 @@ procedure StepA_Mal is
& " (if ~condvar ~condvar (or ~@(rest xs)))))))))"
& "(def! *host-language* ""ada.2"")";
Repl : constant Envs.Ptr := Envs.New_Env;
function Eval_Builtin (Args : in Mal.T_Array) return Mal.T is
function Eval_Builtin (Args : in Types.T_Array) return Types.T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
return Eval_Cb.Cb.all (Args (Args'First), Repl);
return Eval (Args (Args'First), Repl);
end Eval_Builtin;
Script : constant Boolean := 0 < ACL.Argument_Count;
Argv : Mal.Sequence_Ptr;
Argv : constant Types.Sequence_Ptr
:= Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
begin
-- Show the Eval function to other packages.
Eval_Cb.Cb := Eval'Unrestricted_Access;
Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
-- Add Core functions into the top environment.
Core.NS_Add_To_Repl (Repl);
Repl.all.Set (Symbols.Constructor ("eval"),
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
(Kind_Builtin, Eval_Builtin'Unrestricted_Access));
-- Native startup procedure.
Exec (Startup, Repl);
-- Define ARGV from command line arguments.
if Script then
Argv := Sequences.Constructor (ACL.Argument_Count - 1);
for I in 2 .. ACL.Argument_Count loop
Argv.all.Replace_Element
(I - 1, (Kind_String, ASU.To_Unbounded_String (ACL.Argument (I))));
end loop;
else
Argv := Sequences.Constructor (0);
end if;
Repl.all.Set (Symbols.Constructor ("*ARGV*"), (Kind_List, Argv));
for I in 2 .. ACL.Argument_Count loop
Argv.all.Data (I - 1) := (Kind_String,
Types.Strings.Alloc (ACL.Argument (I)));
end loop;
Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
(Kind_List, Argv));
-- Execute user commands.
if Script then
Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
@ -452,7 +484,7 @@ begin
-- Other exceptions are really unexpected.
-- Collect garbage.
Err.Data := Mal.Nil;
Err.Data := Types.Nil;
Repl.all.Keep;
Garbage_Collected.Clean;
end loop;
@ -460,7 +492,8 @@ begin
end if;
-- If assertions are enabled, check deallocations.
-- Normal runs do not need to deallocate before termination.
-- Beware that all pointers are now dangling.
pragma Debug (Garbage_Collected.Clean);
Garbage_Collected.Check_Allocations;
Symbols.Check_Allocations;
end StepA_Mal;

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

@ -1,54 +1,52 @@
with Err;
with Types.Builtins;
with Types.Fns;
package body Types.Atoms is
function Atom (Args : in Mal.T_Array) return Mal.T is
Ref : Mal.Atom_Ptr;
function Atom (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Ref := new Instance'(Garbage_Collected.Instance with
Data => Args (Args'First));
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Atom, Ref);
declare
Ref : constant Atom_Ptr := new Instance;
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
Ref.all.Data := Args (Args'First);
return (Kind_Atom, Ref);
end;
end Atom;
function Deref (Args : in Mal.T_Array) return Mal.T is
function Deref (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Atom, "expected an atom");
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Atom,
"expected an atom");
return Args (Args'First).Atom.all.Data;
end Deref;
function Deref (Item : in Instance) return Mal.T
function Deref (Item : in Instance) return T
is (Item.Data);
procedure Keep_References (Object : in out Instance) is
begin
Mal.Keep (Object.Data);
Keep (Object.Data);
end Keep_References;
function Reset (Args : in Mal.T_Array) return Mal.T is
function Reset (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Atom,
"parameter 1 must be an atom");
Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Atom,
"expected an atom then a value");
Args (Args'First).Atom.all.Data := Args (Args'Last);
return Args (Args'Last);
end Reset;
function Swap (Args : in Mal.T_Array) return Mal.T is
function Swap (Args : in T_Array) return T is
begin
Err.Check (2 <= Args'Length, "expected at least 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Atom,
"parameter 1 must be an atom");
Err.Check (2 <= Args'Length and then Args (Args'First).Kind = Kind_Atom,
"expected an atom, optional arguments then a function");
declare
use type Mal.T_Array;
X : Mal.T renames Args (Args'First).Atom.all.Data;
F : Mal.T renames Args (Args'First + 1);
A : constant Mal.T_Array := X & Args (Args'First + 2 .. Args'Last);
X : T renames Args (Args'First).Atom.all.Data;
F : T renames Args (Args'First + 1);
A : constant T_Array := X & Args (Args'First + 2 .. Args'Last);
begin
case F.Kind is
when Kind_Builtin =>

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

@ -1,24 +1,24 @@
with Garbage_Collected;
with Types.Mal;
package Types.Atoms is
type Instance (<>) is new Garbage_Collected.Instance with private;
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
-- Built-in functions.
function Atom (Args : in Mal.T_Array) return Mal.T;
function Deref (Args : in Mal.T_Array) return Mal.T;
function Reset (Args : in Mal.T_Array) return Mal.T;
function Swap (Args : in Mal.T_Array) return Mal.T;
function Atom (Args : in T_Array) return T;
function Deref (Args : in T_Array) return T;
function Reset (Args : in T_Array) return T;
function Swap (Args : in T_Array) return T;
-- Helper for print.
function Deref (Item : in Instance) return Mal.T with Inline;
function Deref (Item : in Instance) return T with Inline;
private
type Instance is new Garbage_Collected.Instance with record
Data : Mal.T;
Data : T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Atoms;

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

@ -1,20 +1,21 @@
package body Types.Builtins is
function Builtin (Item : in Instance) return Mal.Builtin_Ptr
function Builtin (Item : in Instance) return Builtin_Ptr
is (Item.F_Builtin);
procedure Keep_References (Object : in out Instance) is
begin
Mal.Keep (Object.F_Meta);
Keep (Object.F_Meta);
end Keep_References;
function Meta (Item : in Instance) return Mal.T
function Meta (Item : in Instance) return T
is (Item.F_Meta);
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T
function With_Meta (Builtin : in Builtin_Ptr;
Metadata : in T) return T
is
Ref : constant Mal.Builtin_With_Meta_Ptr
-- Builtin is not null and requires an immediate initialization.
Ref : constant Builtin_With_Meta_Ptr
:= new Instance'(Garbage_Collected.Instance with
F_Builtin => Builtin,
F_Meta => Metadata);
@ -23,8 +24,8 @@ package body Types.Builtins is
return (Kind_Builtin_With_Meta, Ref);
end With_Meta;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T
is (With_Meta (Item.Builtin, Metadata));
function With_Meta (Builtin : in Instance;
Metadata : in T) return T
is (With_Meta (Builtin.F_Builtin, Metadata));
end Types.Builtins;

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

@ -1,28 +1,28 @@
with Garbage_Collected;
with Types.Mal;
package Types.Builtins is
-- Types.Mal.Builtin_Ptr is efficient and sufficient for most
-- purposes, as counting references is a waste of time for native
-- functions. The controlled type below is only useful when one
-- has the silly idea to add metadata to a built-in.
-- purposes, as native function need no deallocation. The type
-- below is only useful to add metadata to a built-in.
type Instance is new Garbage_Collected.Instance with private;
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
function With_Meta (Builtin : in Mal.Builtin_Ptr;
Metadata : in Mal.T) return Mal.T with Inline;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T with Inline;
function Meta (Item : in Instance) return Mal.T with Inline;
function Builtin (Item : in Instance) return Mal.Builtin_Ptr with Inline;
function With_Meta (Builtin : in Builtin_Ptr;
Metadata : in T) return T with Inline;
function With_Meta (Builtin : in Instance;
Metadata : in T) return T with Inline;
function Meta (Item : in Instance) return T with Inline;
function Builtin (Item : in Instance) return Builtin_Ptr with Inline;
private
type Instance is new Garbage_Collected.Instance with record
F_Builtin : Mal.Builtin_Ptr;
F_Meta : Mal.T;
F_Builtin : Builtin_Ptr;
F_Meta : T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Builtins;

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

@ -1,20 +1,22 @@
with Err;
with Eval_Cb;
pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced");
with Types.Sequences;
pragma Warnings (On, "unit ""Types.Sequences"" is not referenced");
package body Types.Fns is
use type Envs.Ptr;
----------------------------------------------------------------------
function Apply (Item : in Instance;
Args : in Mal.T_Array) return Mal.T
is (Eval_Cb.Cb.all (Ast => Item.F_Ast,
Env => Envs.New_Env (Outer => Item.F_Env,
Binds => Item.F_Params,
Exprs => Args)));
Args : in T_Array) return T
is
Env : constant Envs.Ptr := Envs.New_Env (Outer => Item.F_Env);
begin
Env.all.Set_Binds (Binds => Item.F_Params.all.Data,
Exprs => Args);
return Eval_Cb.all (Ast => Item.F_Ast,
Env => Env);
end Apply;
function Ast (Item : in Instance) return Mal.T
function Ast (Item : in Instance) return T
is (Item.F_Ast);
function Env (Item : in Instance) return Envs.Ptr
@ -22,65 +24,36 @@ package body Types.Fns is
procedure Keep_References (Object : in out Instance) is
begin
Mal.Keep (Object.F_Ast);
if Object.F_Env /= null then
Object.F_Env.all.Keep;
end if;
Mal.Keep (Object.F_Meta);
Keep (Object.F_Ast);
Object.F_Params.all.Keep;
Object.F_Env.all.Keep;
Keep (Object.F_Meta);
end Keep_References;
function Meta (Item : in Instance) return Mal.T
function Meta (Item : in Instance) return T
is (Item.F_Meta);
function New_Function (Params : in Sequences.Instance;
Ast : in Mal.T;
Env : in Envs.Ptr)
return Mal.T
function New_Function (Params : in Sequence_Ptr;
Ast : in T;
Env : in Envs.Ptr;
Metadata : in T := Nil) return T
is
Ref : constant Mal.Fn_Ptr
-- Env and Params are not null and require an immediate
-- initialization.
Ref : constant Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Params.Length,
F_Ast => Ast,
F_Env => Env,
others => <>);
F_Ast => Ast,
F_Env => Env,
F_Meta => Metadata,
F_Params => Params);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
for I in Ref.all.F_Params'Range loop
Err.Check (Params (I).Kind = Kind_Symbol,
"formal parameters must be symbols");
Ref.all.F_Params (I) := Params (I).Symbol;
end loop;
Err.Check ((for all P of Params.all.Data => P.Kind = Kind_Symbol),
"formal parameters must be symbols");
return (Kind_Fn, Ref);
end New_Function;
function New_Macro (Item : in Instance) return Mal.T is
Ref : constant Mal.Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Item.Last,
F_Params => Item.F_Params,
F_Ast => Item.F_Ast,
others => <>);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Macro, Ref);
end New_Macro;
function Params (Item : in Instance) return Symbols.Symbol_Array
function Params (Item : in Instance) return Sequence_Ptr
is (Item.F_Params);
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T
is
Ref : constant Mal.Fn_Ptr
:= new Instance'(Garbage_Collected.Instance with
Last => Item.Last,
F_Params => Item.F_Params,
F_Ast => Item.F_Ast,
F_Env => Item.F_Env,
F_Meta => Metadata);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Fn, Ref);
end With_Meta;
end Types.Fns;

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

@ -1,47 +1,44 @@
with Envs;
with Garbage_Collected;
with Types.Mal;
with Types.Sequences;
with Types.Symbols;
package Types.Fns is
type Instance (<>) is new Garbage_Collected.Instance with private;
-- A pointer to an user-defined function or macro.
Eval_Cb : access function (Ast : in T;
Env : in Envs.Ptr) return T;
-- The main program must register this global callback to the main
-- eval function before Apply is called.
function New_Function (Params : in Types.Sequences.Instance;
Ast : in Mal.T;
Env : in Envs.Ptr) return Mal.T
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
function New_Function (Params : in Sequence_Ptr;
Ast : in T;
Env : in Envs.Ptr;
Metadata : in T := Nil) return T
with Inline;
-- Raise an exception if Params contains something else than symbols.
function New_Macro (Item : in Instance) return Mal.T with Inline;
function Params (Item : in Instance) return Symbols.Symbol_Array
function Params (Item : in Instance) return Sequence_Ptr
with Inline;
function Ast (Item : in Instance) return Mal.T with Inline;
function Ast (Item : in Instance) return T with Inline;
-- Useful to print.
function Apply (Item : in Instance;
Args : in Mal.T_Array) return Mal.T with Inline;
-- Returns null for macros.
Args : in T_Array) return T with Inline;
-- Duplicated in the step files because of TCO.
function Env (Item : in Instance) return Envs.Ptr with Inline;
-- Returns null for macros.
-- Required for TCO, instead of Apply.
function Meta (Item : in Instance) return Mal.T with Inline;
function With_Meta (Item : in Instance;
Metadata : in Mal.T) return Mal.T with Inline;
function Meta (Item : in Instance) return T with Inline;
private
type Instance (Last : Natural) is new Garbage_Collected.Instance
type Instance is new Garbage_Collected.Instance
with record
F_Ast : Mal.T;
F_Ast : T;
F_Env : Envs.Ptr;
F_Meta : Mal.T;
F_Params : Symbols.Symbol_Array (1 .. Last);
F_Meta : T;
F_Params : Sequence_Ptr;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;

28
ada.2/types-macros.adb Normal file
View File

@ -0,0 +1,28 @@
pragma Warnings (Off, "unit ""Types.Sequences"" is not referenced");
with Types.Sequences;
pragma Warnings (On, "unit ""Types.Sequences"" is not referenced");
package body Types.Macros is
function Ast (Item : in Instance) return T
is (Item.F_Ast);
procedure Keep_References (Object : in out Instance) is
begin
Keep (Object.F_Ast);
Object.F_Params.all.Keep;
end Keep_References;
function New_Macro (Func : in Fns.Instance) return T is
-- Params is not null and requires an immediate initialization.
Ref : constant Macro_Ptr := new Instance'
(Garbage_Collected.Instance with Func.Ast, Func.Params);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return (Kind_Macro, Ref);
end New_Macro;
function Params (Item : in Instance) return Sequence_Ptr
is (Item.F_Params);
end Types.Macros;

22
ada.2/types-macros.ads Normal file
View File

@ -0,0 +1,22 @@
with Garbage_Collected;
with Types.Fns;
package Types.Macros is
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
function New_Macro (Func : in Fns.Instance) return T with Inline;
function Ast (Item : in Instance) return T with Inline;
function Params (Item : in Instance) return Sequence_Ptr with Inline;
private
type Instance is new Garbage_Collected.Instance with record
F_Ast : T;
F_Params : Sequence_Ptr;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Macros;

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

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

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

@ -1,184 +1,198 @@
with Ada.Strings.Unbounded.Hash;
with Err;
with Types.Sequences;
with Types.Strings;
package body Types.Maps is
function Constructor return Mal.Map_Ptr with Inline;
use type HM.Map;
function Assoc (Initial : in HM.Map;
Bind : in T_Array) return T;
function Constructor return Map_Ptr with Inline;
----------------------------------------------------------------------
function "=" (Left, Right : in Instance) return Boolean
is (Left.Data = Right.Data);
function Assoc (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Map_Ptr := Constructor;
function Assoc (Initial : in HM.Map;
Bind : in T_Array) return T
is
begin
Err.Check (Args'Length mod 2 = 1, "expected an odd parameter count");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
Ref.all.Data := Args (Args'First).Map.all.Data;
for I in 1 .. Args'Length / 2 loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I - 1),
New_Item => Args (Args'First + 2 * I));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
Err.Check (Bind'Length mod 2 = 0, "expected an even bind count");
declare
Len : constant Natural := Bind'Length / 2;
Ref : constant Map_Ptr := Constructor;
begin
Ref.all.Data := Initial;
for I in 0 .. Len - 1 loop
Ref.all.Data.Include (Bind (Bind'First + 2 * I),
Bind (Bind'First + 2 * I + 1));
end loop;
return (Kind_Map, Ref);
end;
end Assoc;
function Contains (Args : in Mal.T_Array) return Mal.T is
function Assoc (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
return (Kind_Boolean,
Args (Args'First).Map.all.Data.Contains (Args (Args'Last)));
end Contains;
Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map,
"first parameter must be a map");
return Assoc (Args (Args'First).Map.all.Data,
Args (Args'First + 1 .. Args'Last));
end Assoc;
function Constructor return Mal.Map_Ptr is
Ref : constant Mal.Map_Ptr := new Instance;
function Constructor return Map_Ptr is
Ref : constant Map_Ptr := new Instance;
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
return Ref;
end Constructor;
function Dissoc (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Map_Ptr := Constructor;
function Contains (Args : in T_Array) return T is
begin
Err.Check (0 < Args'Length, "expected at least 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
Ref.all.Data := Args (Args'First).Map.all.Data;
for I in Args'First + 1 .. Args'Last loop
Ref.all.Data.Exclude (Args (I));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
Err.Check (Args'Length = 2 and then Args (Args'First).Kind = Kind_Map,
"expected a map then a key");
return (Kind_Boolean,
Args (Args'First).Map.all.Data.Contains (Args (Args'Last)));
end Contains;
function Dissoc (Args : in T_Array) return T is
begin
Err.Check (0 < Args'Length and then Args (Args'First).Kind = Kind_Map,
"expected a map then keys");
declare
Ref : constant Map_Ptr := Constructor;
begin
Ref.all.Data := Args (Args'First).Map.all.Data;
for I in Args'First + 1 .. Args'Last loop
Ref.all.Data.Exclude (Args (I));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
end;
end Dissoc;
function Generic_Eval (Container : in Instance;
Env : in Env_Type) return Mal.T
is
-- Copy the whole hash in order to avoid recomputing the hash
-- for each key, even if it implies unneeded calls to adjust
-- and finalize for Mal_Type values.
Ref : constant Mal.Map_Ptr := Constructor;
begin
Ref.Data := Container.Data;
for Position in Ref.all.Data.Iterate loop
Ref.all.Data.Replace_Element (Position,
Eval (HM.Element (Position), Env));
-- This call may raise exceptions.
end loop;
return Mal.T'(Kind_Map, Ref);
end Generic_Eval;
function Element (Position : in Cursor) return T
is (HM.Element (HM.Cursor (Position)));
function Get (Args : in Mal.T_Array) return Mal.T is
Position : HM.Cursor;
function First (Container : in Instance) return Cursor
is (Cursor (Container.Data.First));
function Get (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
case Args (Args'First).Kind is
when Kind_Nil =>
Err.Check (Args (Args'Last).Kind in Kind_Key,
"key must be a keyword or string");
return Mal.Nil;
return Nil;
when Kind_Map =>
Position := Args (Args'First).Map.all.Data.Find (Args (Args'Last));
-- This call checks the kind of the key.
if HM.Has_Element (Position) then
return HM.Element (Position);
else
return Mal.Nil;
end if;
declare
Position : constant HM.Cursor
:= Args (Args'First).Map.all.Data.Find (Args (Args'Last));
begin
if HM.Has_Element (Position) then
return HM.Element (Position);
else
return Nil;
end if;
end;
when others =>
Err.Raise_With ("parameter 1 must be nil or a map");
end case;
end Get;
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type is
function Has_Element (Position : in Cursor) return Boolean
is (HM.Has_Element (HM.Cursor (Position)));
function Hash (Item : in T) return Ada.Containers.Hash_Type is
begin
Err.Check (Item.Kind in Kind_Key, "keys must be keywords or strings");
return (Ada.Strings.Unbounded.Hash (Item.S));
return Strings.Hash (Item.Str);
end Hash;
function Hash_Map (Args : in Mal.T_Array) return Mal.T is
Binds : constant Natural := Args'Length / 2;
Ref : Mal.Map_Ptr;
begin
Err.Check (Args'Length mod 2 = 0, "expected an even parameter count");
Ref := Constructor;
Ref.all.Data.Reserve_Capacity (Ada.Containers.Count_Type (Binds));
for I in 0 .. Binds - 1 loop
Ref.all.Data.Include (Key => Args (Args'First + 2 * I),
New_Item => Args (Args'First + 2 * I + 1));
-- This call checks the kind of the key.
end loop;
return (Kind_Map, Ref);
end Hash_Map;
procedure Iterate (Container : in Instance) is
begin
for Position in Container.Data.Iterate loop
Process (HM.Key (Position), HM.Element (Position));
end loop;
end Iterate;
function Hash_Map (Args : in T_Array) return T
is (Assoc (HM.Empty_Map, Args));
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));
Keep (HM.Key (Position));
Keep (HM.Element (Position));
end loop;
Mal.Keep (Object.F_Meta);
Keep (Object.F_Meta);
end Keep_References;
function Keys (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
function Key (Position : in Cursor) return T
is (HM.Key (HM.Cursor (Position)));
function Keys (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
A1 := Args (Args'First).Map;
R := Sequences.Constructor (A1.all.Length);
for Position in A1.all.Data.Iterate loop
R.all.Replace_Element (I, HM.Key (Position));
I := I + 1;
end loop;
return (Kind_List, R);
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map,
"expected a map");
declare
A1 : HM.Map renames Args (Args'First).Map.all.Data;
Ref : constant Sequence_Ptr
:= Sequences.Constructor (Natural (A1.Length));
I : Positive := 1;
begin
for Position in A1.Iterate loop
Ref.all.Data (I) := HM.Key (Position);
I := I + 1;
end loop;
return (Kind_List, Ref);
end;
end Keys;
function Length (Container : in Instance) return Natural
is (Natural (Container.Data.Length));
function Meta (Container : in Instance) return Mal.T
function Meta (Container : in Instance) return T
is (Container.F_Meta);
function Vals (Args : in Mal.T_Array) return Mal.T is
A1 : Mal.Map_Ptr;
R : Mal.Sequence_Ptr;
I : Positive := 1;
procedure Next (Position : in out Cursor) is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind = Kind_Map,
"parameter 1 must be a map");
A1 := Args (Args'First).Map;
R := Sequences.Constructor (A1.all.Length);
for Element of A1.all.Data loop
R.all.Replace_Element (I, Element);
I := I + 1;
end loop;
return (Kind_List, R);
HM.Next (HM.Cursor (Position));
end Next;
function New_Map (Source : in Instance) return T
is
Ref : constant Map_Ptr := Constructor;
begin
Ref.all.Data := Source.Data;
return (Kind_Map, Ref);
end New_Map;
procedure Replace_Element (Container : in out Instance;
Position : in Cursor;
New_Item : in T)
is
begin
Container.Data.Replace_Element (HM.Cursor (Position), New_Item);
end Replace_Element;
function Vals (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1 and then Args (Args'First).Kind = Kind_Map,
"expected a map");
declare
A1 : HM.Map renames Args (Args'First).Map.all.Data;
R : constant Sequence_Ptr
:= Sequences.Constructor (Natural (A1.Length));
I : Positive := 1;
begin
for Element of A1 loop
R.all.Data (I) := Element;
I := I + 1;
end loop;
return (Kind_List, R);
end;
end Vals;
function With_Meta (Data : in Instance;
Metadata : in Mal.T) return Mal.T
function With_Meta (Container : in Instance;
Metadata : in T) return T
is
Ref : constant Mal.Map_Ptr := Constructor;
Ref : constant Map_Ptr := Constructor;
begin
Ref.all.Data := Data.Data;
Ref.all.Data := Container.Data;
Ref.all.F_Meta := Metadata;
return (Kind_Map, Ref);
end With_Meta;

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

@ -1,67 +1,62 @@
private with Ada.Containers.Hashed_Maps;
with Garbage_Collected;
with Types.Mal;
package Types.Maps is
type Instance (<>) is new Garbage_Collected.Instance with private;
-- All function receiving a key check that its kind is keyword or
-- string.
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
-- Built-in functions.
function Assoc (Args : in Mal.T_Array) return Mal.T;
function Contains (Args : in Mal.T_Array) return Mal.T;
function Dissoc (Args : in Mal.T_Array) return Mal.T;
function Get (Args : in Mal.T_Array) return Mal.T;
function Hash_Map (Args : in Mal.T_Array) return Mal.T;
function Keys (Args : in Mal.T_Array) return Mal.T;
function Vals (Args : in Mal.T_Array) return Mal.T;
function Assoc (Args : in T_Array) return T;
function Contains (Args : in T_Array) return T;
function Dissoc (Args : in T_Array) return T;
function Get (Args : in T_Array) return T;
function Hash_Map (Args : in T_Array) return T;
function Keys (Args : in T_Array) return T;
function Vals (Args : in T_Array) return T;
function "=" (Left, Right : in Instance) return Boolean with Inline;
-- A generic is better than an access to function because of
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89159
-- Used to print each element of a map.
type Cursor (<>) is limited private;
function Has_Element (Position : in Cursor) return Boolean with Inline;
function Key (Position : in Cursor) return T with Inline;
function Element (Position : in Cursor) return T with Inline;
function First (Container : in Instance) return Cursor with Inline;
procedure Next (Position : in out Cursor) with Inline;
-- Used to evaluate each element of a map.
function New_Map (Source : in Instance) return T with Inline;
procedure Replace_Element (Container : in out Instance;
Position : in Cursor;
New_Item : in T) with Inline;
generic
type Env_Type (<>) is limited private;
with function Eval (Ast : in Mal.T;
Env : in Env_Type)
return Mal.T;
function Generic_Eval (Container : in Instance;
Env : in Env_Type)
return Mal.T;
-- Used to print a map.
generic
with procedure Process (Key : in Mal.T;
Element : in Mal.T);
procedure Iterate (Container : in Instance);
function Length (Container : in Instance) return Natural with Inline;
function Meta (Container : in Instance) return Mal.T with Inline;
function With_Meta (Data : in Instance;
Metadata : in Mal.T)
return Mal.T;
function Meta (Container : in Instance) return T with Inline;
function With_Meta (Container : in Instance;
Metadata : in T) return T with Inline;
private
function Hash (Item : in Mal.T) return Ada.Containers.Hash_Type with Inline;
function Hash (Item : in 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,
package HM is new Ada.Containers.Hashed_Maps (Key_Type => T,
Element_Type => T,
Hash => Hash,
Equivalent_Keys => Mal."=",
"=" => Mal."=");
use type HM.Map;
Equivalent_Keys => "=",
"=" => "=");
type Instance is new Garbage_Collected.Instance with record
Data : HM.Map;
F_Meta : Mal.T;
F_Meta : T;
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
type Cursor is new HM.Cursor;
end Types.Maps;

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

@ -1,56 +1,50 @@
with Err;
with Types.Builtins;
with Types.Fns;
with Types.Builtins;
package body Types.Sequences is
use type Mal.T_Array;
----------------------------------------------------------------------
function "=" (Left, Right : in Instance) return Boolean is
-- Should become Left.Ref.all.Data = Right.Ref.all.Data when
-- Should become Left.all.Data = Right.all.Data when
-- https://gcc.gnu.org/bugzilla/show_bug.cgi?id=89178 is fixed.
use type Mal.T;
begin
return Left.Last = Right.Last
return Left.Length = Right.Length
and then
(for all I in 1 .. Left.Last => Left.Data (I) = Right.Data (I));
(for all I in 1 .. Left.Data'Length => Left.Data (I) = Right.Data (I));
end "=";
function "&" (Left : in Mal.T_Array;
Right : in Instance) return Mal.T_Array
is (Left & Right.Data);
function Concat (Args : in Mal.T_Array) return Mal.T is
function Concat (Args : in T_Array) return T is
Sum : Natural := 0;
First : Positive := 1;
Last : Natural;
Ref : Mal.Sequence_Ptr;
begin
Err.Check ((for all A of Args => A.Kind in Kind_Sequence),
"expected sequences");
for Arg of Args loop
Err.Check (Arg.Kind in Kind_Sequence, "expected sequences");
Sum := Sum + Arg.Sequence.all.Data'Length;
end loop;
Ref := Constructor (Sum);
for Arg of Args loop
Last := First - 1 + Arg.Sequence.all.Data'Length;
Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
First := Last + 1;
end loop;
return (Kind_List, Ref);
declare
Ref : constant Sequence_Ptr := Constructor (Sum);
begin
for Arg of Args loop
Last := First - 1 + Arg.Sequence.all.Data'Last;
Ref.all.Data (First .. Last) := Arg.Sequence.all.Data;
First := Last + 1;
end loop;
return (Kind_List, Ref);
end;
end Concat;
function Conj (Args : in Mal.T_Array) return Mal.T is
function Conj (Args : in T_Array) return T is
begin
Err.Check (0 < Args'Length, "expected at least 1 parameter");
case Args (Args'First).Kind is
when Kind_Sequence =>
declare
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
Data : T_Array renames Args (Args'First).Sequence.all.Data;
Last : constant Natural := Args'Length - 1 + Data'Length;
-- Avoid exceptions until Ref is controlled.
Ref : constant Mal.Sequence_Ptr := Constructor (Last);
Ref : constant Sequence_Ptr := Constructor (Last);
begin
if Args (Args'First).Kind = Kind_List then
for I in 1 .. Args'Length - 1 loop
@ -68,29 +62,29 @@ package body Types.Sequences is
end case;
end Conj;
function Cons (Args : in Mal.T_Array) return Mal.T is
function Cons (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
"parameter 2 must be a sequence");
Err.Check (Args'Length = 2
and then Args (Args'Last).Kind in Kind_Sequence,
"expected a value then a sequence");
declare
Head : Mal.T renames Args (Args'First);
Tail : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Mal.Sequence_Ptr := Constructor (1 + Tail'Length);
Head : T renames Args (Args'First);
Tail : T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Sequence_Ptr := Constructor (1 + Tail'Length);
begin
Ref.all.Data := Head & Tail;
return (Kind_List, Ref);
end;
end Cons;
function Constructor (Length : in Natural) return Mal.Sequence_Ptr is
Ref : constant Mal.Sequence_Ptr := new Instance (Length);
function Constructor (Length : in Natural) return Sequence_Ptr is
Ref : constant 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 T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
case Args (Args'First).Kind is
@ -103,22 +97,18 @@ package body Types.Sequences is
end case;
end Count;
function Element (Container : in Instance;
Index : in Positive) return Mal.T
is (Container.Data (Index));
function First (Args : in Mal.T_Array) return Mal.T is
function First (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
case Args (Args'First).Kind is
when Kind_Nil =>
return Mal.Nil;
return Nil;
when Kind_Sequence =>
declare
Data : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
Data : T_Array renames Args (Args'First).Sequence.all.Data;
begin
if Data'Length = 0 then
return Mal.Nil;
return Nil;
else
return Data (Data'First);
end if;
@ -128,41 +118,39 @@ package body Types.Sequences is
end case;
end First;
function Is_Empty (Args : in Mal.T_Array) return Mal.T is
function Is_Empty (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
Err.Check (Args (Args'First).Kind in Kind_Sequence,
"parameter must be a sequence");
Err.Check (Args'Length = 1
and then Args (Args'First).Kind in Kind_Sequence,
"expected a sequence");
return (Kind_Boolean, Args (Args'First).Sequence.all.Data'Length = 0);
end Is_Empty;
procedure Keep_References (Object : in out Instance) is
begin
Mal.Keep (Object.F_Meta);
Keep (Object.Meta);
for M of Object.Data loop
Mal.Keep (M);
Keep (M);
end loop;
end Keep_References;
function Length (Source : in Instance) return Natural
is (Source.Data'Length);
function List (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
function List (Args : in T_Array) return T
is
Ref : constant Sequence_Ptr := Constructor (Args'Length);
begin
Ref.all.Data := Args;
return (Kind_List, Ref);
end List;
function Map (Args : in Mal.T_Array) return Mal.T is
function Map (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'Last).Kind in Kind_Sequence,
"parameter 2 must be a sequence");
Err.Check (Args'Length = 2
and then Args (Args'Last).Kind in Kind_Sequence,
"expected a function then a sequence");
declare
F : Mal.T renames Args (Args'First);
Src : Mal.T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Mal.Sequence_Ptr := Constructor (Src'Length);
F : T renames Args (Args'First);
Src : T_Array renames Args (Args'Last).Sequence.all.Data;
Ref : constant Sequence_Ptr := Constructor (Src'Length);
begin
case F.Kind is
when Kind_Builtin =>
@ -185,18 +173,14 @@ package body Types.Sequences is
end;
end Map;
function Meta (Item : in Instance) return Mal.T
is (Item.F_Meta);
function Nth (Args : in Mal.T_Array) return Mal.T is
function Nth (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 2, "expected 2 parameters");
Err.Check (Args (Args'First).Kind in Kind_Sequence,
"paramater 1 must be a sequence");
Err.Check (Args (Args'Last).Kind = Kind_Number,
"parameter 2 must be a number");
Err.Check (Args'Length = 2
and then Args (Args'First).Kind in Kind_Sequence
and then Args (Args'Last).Kind = Kind_Number,
"expected a sequence then a number");
declare
L : Mal.T_Array renames Args (Args'First).Sequence.all.Data;
L : T_Array renames Args (Args'First).Sequence.all.Data;
I : constant Integer := Args (Args'Last).Number + 1;
begin
Err.Check (I in L'Range, "index out of bounds");
@ -204,62 +188,32 @@ package body Types.Sequences is
end;
end Nth;
procedure Replace_Element (Container : in out Instance;
Index : in Positive;
New_Item : in Mal.T)
is
begin
Container.Data (Index) := New_Item;
end Replace_Element;
function Rest (Args : in Mal.T_Array) return Mal.T is
function Rest (Args : in T_Array) return T is
begin
Err.Check (Args'Length = 1, "expected 1 parameter");
declare
A1 : Mal.T renames Args (Args'First);
Ref : Mal.Sequence_Ptr;
begin
-- Avoid exceptions until Ref is controlled.
case A1.Kind is
when Kind_Nil =>
Ref := Constructor (0);
when Kind_Sequence =>
if A1.Sequence.all.Last = 0 then
Ref := Constructor (0);
else
Ref := Constructor (A1.Sequence.all.Last - 1);
Ref.all.Data
:= A1.Sequence.all.Data (2 .. A1.Sequence.all.Data'Last);
end if;
when others =>
Err.Raise_With ("parameter must be nil or a sequence");
end case;
return (Kind_List, Ref);
end;
case Args (Args'First).Kind is
when Kind_Nil =>
return (Kind_List, Constructor (0));
when Kind_Sequence =>
declare
A1 : T_Array renames Args (Args'First).Sequence.all.Data;
Ref : constant Sequence_Ptr
:= Constructor (Integer'Max (0, A1'Length - 1));
begin
Ref.all.Data := A1 (A1'First + 1 .. A1'Last);
return (Kind_List, Ref);
end;
when others =>
Err.Raise_With ("parameter must be nil or a sequence");
end case;
end Rest;
function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array is
Data : Mal.T_Array renames Source.Data;
begin
return Data (Data'Last - Count + 1 .. Data'Last);
end Tail;
function Vector (Args : in Mal.T_Array) return Mal.T is
Ref : constant Mal.Sequence_Ptr := Constructor (Args'Length);
function Vector (Args : in T_Array) return T
is
Ref : constant Sequence_Ptr := Constructor (Args'Length);
begin
Ref.all.Data := Args;
return (Kind_Vector, Ref);
end Vector;
function With_Meta (Data : in Instance;
Metadata : in Mal.T) return Mal.Sequence_Ptr
is
Ref : constant Mal.Sequence_Ptr := Constructor (Data.Last);
begin
Ref.all.Data := Data.Data;
Ref.all.F_Meta := Metadata;
return Ref;
end With_Meta;
end Types.Sequences;

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

@ -1,59 +1,39 @@
with Garbage_Collected;
with Types.Mal;
package Types.Sequences is
type Instance (<>) is new Garbage_Collected.Instance with private
with Constant_Indexing => Element;
-- Hiding the implementation would either cause a significative
-- performance hit (the compiler performs better optimization with
-- explicit arrays) or a convoluted interface (demonstrated for
-- strings and maps, where the balance is different).
type Instance (Length : Natural) is new Garbage_Collected.Instance with
record
Meta : T;
Data : T_Array (1 .. Length);
end record;
-- Built-in functions.
function Concat (Args : in Mal.T_Array) return Mal.T;
function Conj (Args : in Mal.T_Array) return Mal.T;
function Cons (Args : in Mal.T_Array) return Mal.T;
function Count (Args : in Mal.T_Array) return Mal.T;
function First (Args : in Mal.T_Array) return Mal.T;
function Is_Empty (Args : in Mal.T_Array) return Mal.T;
function List (Args : in Mal.T_Array) return Mal.T;
function Map (Args : in Mal.T_Array) return Mal.T;
function Nth (Args : in Mal.T_Array) return Mal.T;
function Rest (Args : in Mal.T_Array) return Mal.T;
function Vector (Args : in Mal.T_Array) return Mal.T;
function Concat (Args : in T_Array) return T;
function Conj (Args : in T_Array) return T;
function Cons (Args : in T_Array) return T;
function Count (Args : in T_Array) return T;
function First (Args : in T_Array) return T;
function Is_Empty (Args : in T_Array) return T;
function List (Args : in T_Array) return T;
function Map (Args : in T_Array) return T;
function Nth (Args : in T_Array) return T;
function Rest (Args : in T_Array) return T;
function Vector (Args : in T_Array) return T;
function "=" (Left, Right : in Instance) return Boolean with Inline;
-- New instances must be created via this constructor.
function Constructor (Length : in Natural) return Sequence_Ptr with Inline;
function Length (Source : in Instance) return Natural with Inline;
function Element (Container : in Instance;
Index : in Positive) return Mal.T
with Inline, Pre => Index <= Length (Container);
function "&" (Left : in Mal.T_Array;
Right : in Instance) return Mal.T_Array with Inline;
-- Used to implement Core.Apply.
function Constructor (Length : in Natural) return Mal.Sequence_Ptr
with Inline;
procedure Replace_Element (Container : in out Instance;
Index : in Positive;
New_Item : in Mal.T)
with Inline, Pre => Index <= Length (Container);
-- Used in macro implementation.
function Tail (Source : in Instance;
Count : in Natural) return Mal.T_Array
with Inline, Pre => Count <= Length (Source);
function Meta (Item : in Instance) return Mal.T with Inline;
function With_Meta (Data : in Instance;
Metadata : in Mal.T)
return Mal.Sequence_Ptr;
-- Helper for Types."=".
function "=" (Left, Right : in Instance) return Boolean;
private
type Instance (Last : Natural) is new Garbage_Collected.Instance with record
F_Meta : Mal.T;
Data : Mal.T_Array (1 .. Last);
end record;
overriding procedure Keep_References (Object : in out Instance) with Inline;
end Types.Sequences;

34
ada.2/types-strings.adb Normal file
View File

@ -0,0 +1,34 @@
with Ada.Strings.Hash;
package body Types.Strings is
function "=" (Left : in Instance;
Right : in String) return Boolean
is (Left.Data = Right);
function Alloc (Data : in String) return String_Ptr is
Ref : constant String_Ptr := new Instance (Data'Length);
begin
Garbage_Collected.Register (Garbage_Collected.Pointer (Ref));
Ref.all.Data := Data;
return Ref;
end Alloc;
function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type
is (Ada.Strings.Hash (Item.all.Data));
procedure Query_Element
(Container : in Instance;
Process : not null access procedure (Element : in String))
is
begin
Process.all (Container.Data);
end Query_Element;
function Same_Contents (Left, Right : in String_Ptr) return Boolean
is (Left = Right or else Left.all.Data = Right.all.Data);
function To_String (Container : in Instance) return String
is (Container.Data);
end Types.Strings;

49
ada.2/types-strings.ads Normal file
View File

@ -0,0 +1,49 @@
with Ada.Containers;
with Garbage_Collected;
package Types.Strings is
------------------------------------
-- Keywords, Strings and Symbols --
------------------------------------
-- Tests seem to show that manual garbage collection is faster
-- than reference counting in Ada.Strings.Unbounded, probably
-- because we know that the values will never change.
-- Also, maintaining a global structure in order to avoid similar
-- symbol allocations does not seem to improve performances.
type Instance (<>) is abstract new Garbage_Collected.Instance with private;
function Alloc (Data : in String) return String_Ptr
with Inline;
function "=" (Left : in Instance;
Right : in String) return Boolean
with Inline;
-- This kind of accessor is more efficient than a function
-- returning an array.
procedure Query_Element
(Container : in Instance;
Process : not null access procedure (Element : in String));
-- These methods could be implemented with Query_Element,
-- but we want to optimize Envs.Get.
function Hash (Item : in String_Ptr) return Ada.Containers.Hash_Type
with Inline;
function Same_Contents (Left, Right : in String_Ptr) return Boolean
with Inline;
-- When readability is more important than copying a string.
function To_String (Container : in Instance) return String with Inline;
private
type Instance (Last : Natural) is new Garbage_Collected.Instance with record
Data : String (1 .. Last);
end record;
end Types.Strings;

30
ada.2/types-symbols-names.ads
View File

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

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

@ -1,84 +0,0 @@
with Ada.Containers.Hashed_Sets;
with Ada.Strings.Hash;
with Ada.Unchecked_Deallocation;
package body Types.Symbols is
type Rec (Last : Positive) is limited record
Refs : Natural;
Data : String (1 .. Last);
end record;
procedure Free is new Ada.Unchecked_Deallocation (Rec, Acc);
Allocations : Natural := 0;
function Hash (Item : in Acc) return Ada.Containers.Hash_Type with Inline;
package Sets is new Ada.Containers.Hashed_Sets (Element_Type => Acc,
Hash => Hash,
Equivalent_Elements => "=",
"=" => "=");
function Key (Item : in Acc) return String with Inline;
package Keys is new Sets.Generic_Keys (Key_Type => String,
Key => Key,
Hash => Ada.Strings.Hash,
Equivalent_Keys => "=");
Dict : Sets.Set;
----------------------------------------------------------------------
procedure Adjust (Object : in out Ptr) is
begin
Object.Ref.all.Refs := @ + 1;
end Adjust;
procedure Check_Allocations is
begin
-- See Types.Symbols.Names.
pragma Assert (Allocations = 15);
end Check_Allocations;
function Constructor (Source : in String) return Ptr is
Position : constant Sets.Cursor := Keys.Find (Dict, Source);
Ref : Acc;
begin
-- Avoid exceptions until Ref is controlled.
if Sets.Has_Element (Position) then
Ref := Sets.Element (Position);
Ref.all.Refs := Ref.all.Refs + 1;
else
Allocations := Allocations + 1;
Ref := new Rec'(Data => Source,
Last => Source'Length,
Refs => 1);
Dict.Insert (Ref);
end if;
return (Ada.Finalization.Controlled with Ref);
end Constructor;
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
Dict.Delete (Object.Ref);
Allocations := Allocations - 1;
Free (Object.Ref);
end if;
end if;
end Finalize;
function Hash (Item : in Acc) return Ada.Containers.Hash_Type
is (Ada.Strings.Hash (Item.all.Data));
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type
is (Ada.Strings.Hash (Item.Ref.all.Data));
function Key (Item : in Acc) return String
is (Item.all.Data);
function To_String (Item : in Ptr) return String
is (Item.Ref.all.Data);
end Types.Symbols;

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

@ -1,67 +0,0 @@
with Ada.Containers;
private with Ada.Finalization;
package Types.Symbols with Preelaborate is
-- Like keys, symbols are immutable final nodes in the internal
-- data structures. For them, reference counting is probably more
-- efficient than garbage collecting.
type Ptr is tagged private;
function Constructor (Source : in String) return Ptr with Inline;
function To_String (Item : in Ptr) return String with Inline;
-- The hash value is made available because symbols have a high
-- probability to end up as keys in an environment.
function Hash (Item : in Ptr) return Ada.Containers.Hash_Type with Inline;
-- 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 Ptr;
Empty_Array : constant Symbol_Array;
-- It is convenient to define this here because the default value
-- for Ptr is invalid.
-- Debug.
procedure Check_Allocations with Inline;
-- Does nothing if assertions are disabled.
private
-- Only one instance is allocated with a given content. This
-- avoids many allocations and deallocations, since symbols are
-- expected to be used many times.
-- Tests seem to show that this solution is a few percents faster
-- than Ada.Strings.Unbounded.
-- As a side effect, some frequent string comparisons (with "def!"
-- or "fn*" for example) will become a bit more efficient because
-- comparing pointers is faster than comparing strings.
-- It would be natural to store a Cursor from the global
-- dictionnary into Ptr, but this actually reduces the speed,
-- probably because it significantly increases the size of
-- Mal_Type.
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;
-- Predefined equality is fine.
pragma Finalize_Storage_Only (Ptr);
Empty_Array : constant Symbol_Array
:= (1 .. 0 => (Ada.Finalization.Controlled with null));
-- This will not trigger the invariant check because no element is
-- ever actually instantiated.
end Types.Symbols;

41
ada.2/types-mal.adb → ada.2/types.adb
View File

@ -1,17 +1,14 @@
pragma Warnings (Off, "no entities of ""Types.*"" are referenced");
with Types.Atoms;
with Types.Builtins;
with Types.Fns;
with Types.Macros;
with Types.Maps;
with Types.Sequences;
with Types.Fns;
pragma Warnings (On, "no entities of ""Types.*"" are referenced");
with Types.Strings;
package body Types.Mal is
use type Ada.Strings.Unbounded.Unbounded_String;
use type Maps.Instance;
use type Sequences.Instance;
use type Symbols.Ptr;
----------------------------------------------------------------------
package body Types is
function "=" (Left, Right : in T) return Boolean
is (case Left.Kind is
@ -22,26 +19,30 @@ package body Types.Mal is
and then Left.Ada_Boolean = Right.Ada_Boolean,
when Kind_Number =>
Right.Kind = Kind_Number and then Left.Number = Right.Number,
when Kind_Symbol =>
Right.Kind = Kind_Symbol and then Left.Symbol = Right.Symbol,
when Kind_Key =>
Right.Kind = Left.Kind and then Left.S = Right.S,
-- Here comes the part that differs from the predefined equality.
when Kind_Key | Kind_Symbol =>
Right.Kind = Left.Kind
and then Strings.Same_Contents (Left.Str, Right.Str),
when Kind_Sequence =>
Right.Kind in Kind_Sequence
and then Left.Sequence.all = Right.Sequence.all,
and then (Left.Sequence = Right.Sequence
or else Sequences."=" (Left.Sequence.all, Right.Sequence.all)),
when Kind_Map =>
Right.Kind = Kind_Map and then Left.Map.all = Right.Map.all,
Right.Kind = Kind_Map
and then (Left.Map = Right.Map
or else Maps."=" (Left.Map.all, Right.Map.all)),
-- Also, comparing functions is an interesting problem.
when others =>
False);
procedure Keep (Object : in T) is
-- No dynamic dispatching happens here.
begin
case Object.Kind is
when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Key | Kind_Builtin
| Kind_Symbol =>
when Kind_Nil | Kind_Boolean | Kind_Number | Kind_Builtin =>
null;
when Kind_Key | Kind_Symbol =>
Object.Str.all.Keep;
when Kind_Atom =>
Object.Atom.all.Keep;
when Kind_Sequence =>
@ -50,9 +51,11 @@ package body Types.Mal is
Object.Map.all.Keep;
when Kind_Builtin_With_Meta =>
Object.Builtin_With_Meta.all.Keep;
when Kind_Fn | Kind_Macro =>
when Kind_Fn =>
Object.Fn.all.Keep;
when Kind_Macro =>
Object.Macro.all.Keep;
end case;
end Keep;
end Types.Mal;
end Types;

78
ada.2/types.ads
View File

@ -1,4 +1,32 @@
package Types with Pure is
limited with Types.Atoms;
limited with Types.Builtins;
limited with Types.Fns;
limited with Types.Macros;
limited with Types.Maps;
limited with Types.Sequences;
limited with Types.Strings;
package Types is
-- A type with a default value for the discriminant is the Ada
-- equivalent of a C union. It uses a fixed size, and allows
-- efficient arrays. A class hierarchy would make this impossible,
-- for little gain.
-- Native types may seem to consume too much memory, but
-- 1/ they require no allocation/deallocation.
-- 2/ the overhead would actually be higher with an intermediate
-- reference (the size of the pointer plus the size of the native
-- type, while an union uses the minimum of both and a single
-- memory area ).
-- The idea is inspired from the Haskell and OCaml interpreters,
-- which use a bit to distinguish pointers from integers. Ada
-- allows to specify the bit position of each component, but
-- generating such architecture-dependent definitions seems a lot
-- of work for MAL.
-- The Ada tradition is to give explicit names to types, but this
-- one will be used very often.
type Kind_Type is
(Kind_Nil,
@ -15,4 +43,52 @@ package Types with Pure is
subtype Kind_Sequence is Kind_Type range Kind_List .. Kind_Vector;
subtype Kind_Function is Kind_Type range Kind_Fn .. Kind_Builtin;
type T;
type T_Array;
type Atom_Ptr is not null access Atoms.Instance;
type Builtin_Ptr is not null access function (Args : in T_Array) return T;
type Builtin_With_Meta_Ptr is not null access Builtins.Instance;
type Fn_Ptr is not null access Fns.Instance;
type Macro_Ptr is not null access Macros.Instance;
type Map_Ptr is not null access Maps.Instance;
type Sequence_Ptr is not null access Sequences.Instance;
type String_Ptr is not null access Strings.Instance;
type T (Kind : Kind_Type := Kind_Nil) is record
case Kind is
when Kind_Nil =>
null;
when Kind_Boolean =>
Ada_Boolean : Boolean;
when Kind_Number =>
Number : Integer;
when Kind_Atom =>
Atom : Atom_Ptr;
when Kind_Key | Kind_Symbol =>
Str : String_Ptr;
when Kind_Sequence =>
Sequence : Sequence_Ptr;
when Kind_Map =>
Map : Map_Ptr;
when Kind_Builtin =>
Builtin : Builtin_Ptr;
when Kind_Builtin_With_Meta =>
Builtin_With_Meta : Builtin_With_Meta_Ptr;
when Kind_Fn =>
Fn : Fn_Ptr;
when Kind_Macro =>
Macro : Macro_Ptr;
end case;
end record;
-- Useful for recursive automatic definition of equality for
-- composite types like the array type below.
function "=" (Left, Right : in T) return Boolean with Inline;
Nil : constant T := (Kind => Kind_Nil);
procedure Keep (Object : in T) with Inline;
type T_Array is array (Positive range <>) of T;
end Types;