ada.2/step5_tco.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 Step5_Tco 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 (Ast0 : in Types.T;
  27                   Env0 : 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 (Ast0 : in Types.T;
  46                   Env0 : in Envs.Ptr) return Types.T
  47    is
  48       --  Use local variables, that can be rewritten when tail call
  49       --  optimization goes to <<Restart>>.
  50       Ast            : Types.T  := Ast0;
  51       Env            : Envs.Ptr := Env0;
  52       Env_Reusable   : Boolean  := False;
  53       --  True when the environment has been created in this recursion
  54       --  level, and has not yet been referenced by a closure. If so,
  55       --  we can reuse it instead of creating a subenvironment.
  56       First          : Types.T;
  57    begin
  58       <<Restart>>
  59       if Dbgeval then
  60          Ada.Text_IO.New_Line;
  61          Ada.Text_IO.Put ("EVAL: ");
  62          Print (Ast);
  63          Envs.Dump_Stack (Env.all);
  64       end if;
  65
  66       case Ast.Kind is
  67       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
  68         | Kind_Macro | Types.Kind_Function =>
  69          return Ast;
  70       when Kind_Symbol =>
  71          return Env.all.Get (Ast.Str);
  72       when Kind_Map =>
  73          return Eval_Map (Ast.Map.all, Env);
  74       when Kind_Vector =>
  75          return Eval_Vector (Ast.Sequence.all, Env);
  76       when Kind_List =>
  77          null;
  78       end case;
  79
  80       --  Ast is a list.
  81       if Ast.Sequence.all.Length = 0 then
  82          return Ast;
  83       end if;
  84       First := Ast.Sequence.all.Data (1);
  85
  86       --  Special forms
  87       --  Ast is a non-empty list, First is its first element.
  88       case First.Kind is
  89       when Kind_Symbol =>
  90          if First.Str.all = "if" then
  91             Err.Check (Ast.Sequence.all.Length in 3 .. 4,
  92                        "expected 2 or 3 parameters");
  93             declare
  94                Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
  95             begin
  96                if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
  97                   Ast := Ast.Sequence.all.Data (3);
  98                   goto Restart;
  99                elsif Ast.Sequence.all.Length = 3 then
 100                   return Types.Nil;
 101                else
 102                   Ast := Ast.Sequence.all.Data (4);
 103                   goto Restart;
 104                end if;
 105             end;
 106          elsif First.Str.all = "let*" then
 107             Err.Check (Ast.Sequence.all.Length = 3
 108                and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
 109                        "expected a sequence then a value");
 110             declare
 111                Bindings : Types.T_Array
 112                  renames Ast.Sequence.all.Data (2).Sequence.all.Data;
 113             begin
 114                Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
 115                if not Env_Reusable then
 116                   Env := Envs.New_Env (Outer => Env);
 117                   Env_Reusable := True;
 118                end if;
 119                for I in 0 .. Bindings'Length / 2 - 1 loop
 120                   Env.all.Set (Bindings (Bindings'First + 2 * I),
 121                          Eval (Bindings (Bindings'First + 2 * I + 1), Env));
 122                   --  This call checks key kind.
 123                end loop;
 124                Ast := Ast.Sequence.all.Data (3);
 125                goto Restart;
 126             end;
 127          elsif First.Str.all = "def!" then
 128             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 129             declare
 130                Key : Types.T renames Ast.Sequence.all.Data (2);
 131                Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
 132             begin
 133                Env.all.Set (Key, Val); --  Check key kind.
 134                return Val;
 135             end;
 136          --  do is a built-in function, shortening this test cascade.
 137          elsif First.Str.all = "fn*" then
 138             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 139             declare
 140                Params : Types.T renames Ast.Sequence.all.Data (2);
 141             begin
 142                Err.Check (Params.Kind in Types.Kind_Sequence,
 143                           "first argument of fn* must be a sequence");
 144                Env_Reusable := False;
 145                return Types.Fns.New_Function
 146                  (Params => Params.Sequence,
 147                   Ast    => Ast.Sequence.all.Data (3),
 148                   Env    => Env);
 149             end;
 150          else
 151             --  Equivalent to First := Eval (First, Env)
 152             --  except that we already know enough to spare a recursive call.
 153             First := Env.all.Get (First.Str);
 154          end if;
 155       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
 156         | Kind_Macro | Types.Kind_Function =>
 157          --  Equivalent to First := Eval (First, Env)
 158          --  except that we already know enough to spare a recursive call.
 159          null;
 160       when Types.Kind_Sequence | Kind_Map =>
 161          --  Lists are definitely worth a recursion, and the two other
 162          --  cases should be rare (they will report an error later).
 163          First := Eval (First, Env);
 164       end case;
 165
 166       --  Apply phase.
 167       --  Ast is a non-empty list,
 168       --  First is its non-special evaluated first element.
 169       Err.Check (First.Kind in Types.Kind_Function,
 170                  "first element must be a function");
 171       --  We are applying a function. Evaluate its arguments.
 172       declare
 173          Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
 174       begin
 175          for I in Args'Range loop
 176             Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
 177          end loop;
 178          if First.Kind = Kind_Builtin then
 179             return First.Builtin.all (Args);
 180          end if;
 181          --  Like Types.Fns.Apply, except that we use TCO.
 182          Env := Envs.New_Env (Outer => First.Fn.all.Env);
 183          Env_Reusable := True;
 184          Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
 185                             Exprs => Args);
 186          Ast := First.Fn.all.Ast;
 187          goto Restart;
 188       end;
 189    exception
 190       when Err.Error =>
 191          Err.Add_Trace_Line ("eval", Ast);
 192          raise;
 193    end Eval;
 194
 195    function Eval_Map (Source : in Types.Maps.Instance;
 196                       Env    : in Envs.Ptr) return Types.T
 197    is
 198       use all type Types.Maps.Cursor;
 199       --  Copy the whole map so that keys are not hashed again.
 200       Result   : constant Types.T  := Types.Maps.New_Map (Source);
 201       Position : Types.Maps.Cursor := Result.Map.all.First;
 202    begin
 203       while Has_Element (Position) loop
 204          Result.Map.all.Replace_Element (Position,
 205                                          Eval (Element (Position), Env));
 206          Next (Position);
 207       end loop;
 208       return Result;
 209    end Eval_Map;
 210
 211    function Eval_Vector (Source : in Types.Sequences.Instance;
 212                          Env    : in Envs.Ptr) return Types.T
 213    is
 214       Ref : constant Types.Sequence_Ptr
 215         := Types.Sequences.Constructor (Source.Length);
 216    begin
 217       for I in Source.Data'Range loop
 218          Ref.all.Data (I) := Eval (Source.Data (I), Env);
 219       end loop;
 220       return (Kind_Vector, Ref);
 221    end Eval_Vector;
 222
 223    procedure Exec (Script : in String;
 224                    Env    : in Envs.Ptr)
 225    is
 226       Result : Types.T;
 227    begin
 228       for Expression of Reader.Read_Str (Script) loop
 229          Result := Eval (Expression, Env);
 230       end loop;
 231       pragma Unreferenced (Result);
 232    end Exec;
 233
 234    procedure Print (Ast : in Types.T) is
 235    begin
 236       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
 237    end Print;
 238
 239    function Read return Types.T_Array
 240    is (Reader.Read_Str (Readline.Input ("user> ")));
 241
 242    procedure Rep (Env : in Envs.Ptr) is
 243    begin
 244       for Expression of Read loop
 245          Print (Eval (Expression, Env));
 246       end loop;
 247    end Rep;
 248
 249    ----------------------------------------------------------------------
 250
 251    Startup : constant String
 252      := "(def! not (fn* (a) (if a false true)))";
 253    Repl   : constant Envs.Ptr := Envs.New_Env;
 254 begin
 255    --  Show the Eval function to other packages.
 256    Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
 257    --  Add Core functions into the top environment.
 258    Core.NS_Add_To_Repl (Repl);
 259    --  Native startup procedure.
 260    Exec (Startup, Repl);
 261    --  Execute user commands.
 262    loop
 263       begin
 264          Rep (Repl);
 265       exception
 266          when Readline.End_Of_File =>
 267             exit;
 268          when Err.Error =>
 269             Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
 270       end;
 271       --  Other exceptions are really unexpected.
 272
 273       --  Collect garbage.
 274       Err.Data := Types.Nil;
 275       Repl.all.Keep;
 276       Garbage_Collected.Clean;
 277    end loop;
 278    Ada.Text_IO.New_Line;
 279
 280    --  If assertions are enabled, check deallocations.
 281    --  Normal runs do not need to deallocate before termination.
 282    --  Beware that all pointers are now dangling.
 283    pragma Debug (Garbage_Collected.Clean);
 284    Garbage_Collected.Check_Allocations;
 285 end Step5_Tco;