ada.2/step6_file.adb

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