ada.2/step4_if_fn_do.adb

   1 with Ada.Environment_Variables;
   2 with Ada.Text_IO.Unbounded_IO;
   3
   4 with Core;
   5 with Envs;
   6 with Err;
   7 with Garbage_Collected;
   8 with Printer;
   9 with Reader;
  10 with Readline;
  11 with Types.Fns;
  12 with Types.Maps;
  13 with Types.Sequences;
  14 with Types.Strings;
  15
  16 procedure Step4_If_Fn_Do is
  17
  18    Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
  19
  20    use type Types.T;
  21    use all type Types.Kind_Type;
  22    use type Types.Strings.Instance;
  23
  24    function Read return Types.T_Array with Inline;
  25
  26    function Eval (Ast : in Types.T;
  27                   Env : in Envs.Ptr) return Types.T;
  28
  29    procedure Print (Ast : in Types.T) with Inline;
  30
  31    procedure Rep (Env : in Envs.Ptr) with Inline;
  32
  33    function Eval_Map (Source : in Types.Maps.Instance;
  34                       Env    : in Envs.Ptr) return Types.T;
  35    function Eval_Vector (Source : in Types.Sequences.Instance;
  36                          Env    : in Envs.Ptr) return Types.T;
  37    --  Helpers for the Eval function.
  38
  39    procedure Exec (Script : in String;
  40                    Env    : in Envs.Ptr) with Inline;
  41    --  Read the script, eval its elements, but ignore the result.
  42
  43    ----------------------------------------------------------------------
  44
  45    function Eval (Ast : in Types.T;
  46                   Env : in Envs.Ptr) return Types.T
  47    is
  48       First          : Types.T;
  49    begin
  50       if Dbgeval then
  51          Ada.Text_IO.New_Line;
  52          Ada.Text_IO.Put ("EVAL: ");
  53          Print (Ast);
  54          Envs.Dump_Stack (Env.all);
  55       end if;
  56
  57       case Ast.Kind is
  58       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
  59         | Kind_Macro | Types.Kind_Function =>
  60          return Ast;
  61       when Kind_Symbol =>
  62          return Env.all.Get (Ast.Str);
  63       when Kind_Map =>
  64          return Eval_Map (Ast.Map.all, Env);
  65       when Kind_Vector =>
  66          return Eval_Vector (Ast.Sequence.all, Env);
  67       when Kind_List =>
  68          null;
  69       end case;
  70
  71       --  Ast is a list.
  72       if Ast.Sequence.all.Length = 0 then
  73          return Ast;
  74       end if;
  75       First := Ast.Sequence.all.Data (1);
  76
  77       --  Special forms
  78       --  Ast is a non-empty list, First is its first element.
  79       case First.Kind is
  80       when Kind_Symbol =>
  81          if First.Str.all = "if" then
  82             Err.Check (Ast.Sequence.all.Length in 3 .. 4,
  83                        "expected 2 or 3 parameters");
  84             declare
  85                Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
  86             begin
  87                if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
  88                   return Eval (Ast.Sequence.all.Data (3), Env);
  89                elsif Ast.Sequence.all.Length = 3 then
  90                   return Types.Nil;
  91                else
  92                   return Eval (Ast.Sequence.all.Data (4), Env);
  93                end if;
  94             end;
  95          elsif First.Str.all = "let*" then
  96             Err.Check (Ast.Sequence.all.Length = 3
  97                and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
  98                        "expected a sequence then a value");
  99             declare
 100                Bindings : Types.T_Array
 101                  renames Ast.Sequence.all.Data (2).Sequence.all.Data;
 102                New_Env  : constant Envs.Ptr := Envs.New_Env (Outer => Env);
 103             begin
 104                Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
 105                for I in 0 .. Bindings'Length / 2 - 1 loop
 106                   New_Env.all.Set (Bindings (Bindings'First + 2 * I),
 107                      Eval (Bindings (Bindings'First + 2 * I + 1), New_Env));
 108                   --  This call checks key kind.
 109                end loop;
 110                return Eval (Ast.Sequence.all.Data (3), New_Env);
 111             end;
 112          elsif First.Str.all = "def!" then
 113             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 114             declare
 115                Key : Types.T renames Ast.Sequence.all.Data (2);
 116                Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
 117             begin
 118                Env.all.Set (Key, Val); --  Check key kind.
 119                return Val;
 120             end;
 121          --  do is a built-in function, shortening this test cascade.
 122          elsif First.Str.all = "fn*" then
 123             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 124             declare
 125                Params : Types.T renames Ast.Sequence.all.Data (2);
 126             begin
 127                Err.Check (Params.Kind in Types.Kind_Sequence,
 128                           "first argument of fn* must be a sequence");
 129                return Types.Fns.New_Function
 130                  (Params => Params.Sequence,
 131                   Ast    => Ast.Sequence.all.Data (3),
 132                   Env    => Env);
 133             end;
 134          else
 135             First := Eval (First, Env);
 136          end if;
 137       when others =>
 138          First := Eval (First, Env);
 139       end case;
 140
 141       --  Apply phase.
 142       --  Ast is a non-empty list,
 143       --  First is its non-special evaluated first element.
 144       Err.Check (First.Kind in Types.Kind_Function,
 145                  "first element must be a function");
 146       --  We are applying a function. Evaluate its arguments.
 147       declare
 148          Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
 149       begin
 150          for I in Args'Range loop
 151             Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
 152          end loop;
 153          if First.Kind = Kind_Builtin then
 154             return First.Builtin.all (Args);
 155          end if;
 156          return First.Fn.all.Apply (Args);
 157       end;
 158    exception
 159       when Err.Error =>
 160          Err.Add_Trace_Line ("eval", Ast);
 161          raise;
 162    end Eval;
 163
 164    function Eval_Map (Source : in Types.Maps.Instance;
 165                       Env    : in Envs.Ptr) return Types.T
 166    is
 167       use all type Types.Maps.Cursor;
 168       --  Copy the whole map so that keys are not hashed again.
 169       Result   : constant Types.T  := Types.Maps.New_Map (Source);
 170       Position : Types.Maps.Cursor := Result.Map.all.First;
 171    begin
 172       while Has_Element (Position) loop
 173          Result.Map.all.Replace_Element (Position,
 174                                          Eval (Element (Position), Env));
 175          Next (Position);
 176       end loop;
 177       return Result;
 178    end Eval_Map;
 179
 180    function Eval_Vector (Source : in Types.Sequences.Instance;
 181                          Env    : in Envs.Ptr) return Types.T
 182    is
 183       Ref : constant Types.Sequence_Ptr
 184         := Types.Sequences.Constructor (Source.Length);
 185    begin
 186       for I in Source.Data'Range loop
 187          Ref.all.Data (I) := Eval (Source.Data (I), Env);
 188       end loop;
 189       return (Kind_Vector, Ref);
 190    end Eval_Vector;
 191
 192    procedure Exec (Script : in String;
 193                    Env    : in Envs.Ptr)
 194    is
 195       Result : Types.T;
 196    begin
 197       for Expression of Reader.Read_Str (Script) loop
 198          Result := Eval (Expression, Env);
 199       end loop;
 200       pragma Unreferenced (Result);
 201    end Exec;
 202
 203    procedure Print (Ast : in Types.T) is
 204    begin
 205       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
 206    end Print;
 207
 208    function Read return Types.T_Array
 209    is (Reader.Read_Str (Readline.Input ("user> ")));
 210
 211    procedure Rep (Env : in Envs.Ptr) is
 212    begin
 213       for Expression of Read loop
 214          Print (Eval (Expression, Env));
 215       end loop;
 216    end Rep;
 217
 218    ----------------------------------------------------------------------
 219
 220    Startup : constant String
 221      := "(def! not (fn* (a) (if a false true)))";
 222    Repl   : constant Envs.Ptr := Envs.New_Env;
 223 begin
 224    --  Show the Eval function to other packages.
 225    Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
 226    --  Add Core functions into the top environment.
 227    Core.NS_Add_To_Repl (Repl);
 228    --  Native startup procedure.
 229    Exec (Startup, Repl);
 230    --  Execute user commands.
 231    loop
 232       begin
 233          Rep (Repl);
 234       exception
 235          when Readline.End_Of_File =>
 236             exit;
 237          when Err.Error =>
 238             Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
 239       end;
 240       --  Other exceptions are really unexpected.
 241
 242       --  Collect garbage.
 243       Err.Data := Types.Nil;
 244       Repl.all.Keep;
 245       Garbage_Collected.Clean;
 246    end loop;
 247    Ada.Text_IO.New_Line;
 248
 249    --  If assertions are enabled, check deallocations.
 250    --  Normal runs do not need to deallocate before termination.
 251    --  Beware that all pointers are now dangling.
 252    pragma Debug (Garbage_Collected.Clean);
 253    Garbage_Collected.Check_Allocations;
 254 end Step4_If_Fn_Do;