ada.2/step8_macros.adb

   1 with Ada.Command_Line;
   2 with Ada.Containers.Vectors;
   3 with Ada.Environment_Variables;
   4 with Ada.Text_IO.Unbounded_IO;
   5
   6 with Core;
   7 with Envs;
   8 with Err;
   9 with Garbage_Collected;
  10 with Printer;
  11 with Reader;
  12 with Readline;
  13 with Types.Fns;
  14 with Types.Macros;
  15 with Types.Maps;
  16 with Types.Sequences;
  17 with Types.Strings;
  18
  19 procedure Step8_Macros is
  20
  21    Dbgeval : constant Boolean := Ada.Environment_Variables.Exists ("dbgeval");
  22
  23    use type Types.T;
  24    use all type Types.Kind_Type;
  25    use type Types.Strings.Instance;
  26    package ACL renames Ada.Command_Line;
  27    package Vectors is new Ada.Containers.Vectors (Positive, Types.T);
  28
  29    function Read return Types.T_Array with Inline;
  30
  31    function Eval (Ast0 : in Types.T;
  32                   Env0 : in Envs.Ptr) return Types.T;
  33    function Eval_Builtin (Args : in Types.T_Array) return Types.T;
  34    --  The built-in variant needs to see the Repl variable.
  35
  36    function Quasiquote (Ast : in Types.T;
  37                         Env : in Envs.Ptr) return Types.T;
  38    --  Mergeing quote and quasiquote into eval with a flag triggering
  39    --  a different behaviour as done for macros in step8 would improve
  40    --  the performances significantly, but Kanaka finds that it breaks
  41    --  too much the step structure shared by all implementations.
  42
  43    procedure Print (Ast : in Types.T) with Inline;
  44
  45    procedure Rep (Env : in Envs.Ptr) with Inline;
  46
  47    function Eval_Map (Source : in Types.Maps.Instance;
  48                       Env    : in Envs.Ptr) return Types.T;
  49    function Eval_Vector (Source : in Types.Sequences.Instance;
  50                          Env    : in Envs.Ptr) return Types.T;
  51    --  Helpers for the Eval function.
  52
  53    procedure Exec (Script : in String;
  54                    Env    : in Envs.Ptr) with Inline;
  55    --  Read the script, eval its elements, but ignore the result.
  56
  57    ----------------------------------------------------------------------
  58
  59    function Eval (Ast0 : in Types.T;
  60                   Env0 : in Envs.Ptr) return Types.T
  61    is
  62       --  Use local variables, that can be rewritten when tail call
  63       --  optimization goes to <<Restart>>.
  64       Ast            : Types.T  := Ast0;
  65       Env            : Envs.Ptr := Env0;
  66       Env_Reusable   : Boolean  := False;
  67       --  True when the environment has been created in this recursion
  68       --  level, and has not yet been referenced by a closure. If so,
  69       --  we can reuse it instead of creating a subenvironment.
  70       Macroexpanding : Boolean  := False;
  71       First          : Types.T;
  72    begin
  73       <<Restart>>
  74       if Dbgeval then
  75          Ada.Text_IO.New_Line;
  76          Ada.Text_IO.Put ("EVAL: ");
  77          Print (Ast);
  78          Envs.Dump_Stack (Env.all);
  79       end if;
  80
  81       case Ast.Kind is
  82       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
  83         | Kind_Macro | Types.Kind_Function =>
  84          return Ast;
  85       when Kind_Symbol =>
  86          return Env.all.Get (Ast.Str);
  87       when Kind_Map =>
  88          return Eval_Map (Ast.Map.all, Env);
  89       when Kind_Vector =>
  90          return Eval_Vector (Ast.Sequence.all, Env);
  91       when Kind_List =>
  92          null;
  93       end case;
  94
  95       --  Ast is a list.
  96       if Ast.Sequence.all.Length = 0 then
  97          return Ast;
  98       end if;
  99       First := Ast.Sequence.all.Data (1);
 100
 101       --  Special forms
 102       --  Ast is a non-empty list, First is its first element.
 103       case First.Kind is
 104       when Kind_Symbol =>
 105          if First.Str.all = "if" then
 106             Err.Check (Ast.Sequence.all.Length in 3 .. 4,
 107                        "expected 2 or 3 parameters");
 108             declare
 109                Tst : constant Types.T := Eval (Ast.Sequence.all.Data (2), Env);
 110             begin
 111                if Tst /= Types.Nil and Tst /= (Kind_Boolean, False) then
 112                   Ast := Ast.Sequence.all.Data (3);
 113                   goto Restart;
 114                elsif Ast.Sequence.all.Length = 3 then
 115                   return Types.Nil;
 116                else
 117                   Ast := Ast.Sequence.all.Data (4);
 118                   goto Restart;
 119                end if;
 120             end;
 121          elsif First.Str.all = "let*" then
 122             Err.Check (Ast.Sequence.all.Length = 3
 123                and then Ast.Sequence.all.Data (2).Kind in Types.Kind_Sequence,
 124                        "expected a sequence then a value");
 125             declare
 126                Bindings : Types.T_Array
 127                  renames Ast.Sequence.all.Data (2).Sequence.all.Data;
 128             begin
 129                Err.Check (Bindings'Length mod 2 = 0, "expected even binds");
 130                if not Env_Reusable then
 131                   Env := Envs.New_Env (Outer => Env);
 132                   Env_Reusable := True;
 133                end if;
 134                for I in 0 .. Bindings'Length / 2 - 1 loop
 135                   Env.all.Set (Bindings (Bindings'First + 2 * I),
 136                          Eval (Bindings (Bindings'First + 2 * I + 1), Env));
 137                   --  This call checks key kind.
 138                end loop;
 139                Ast := Ast.Sequence.all.Data (3);
 140                goto Restart;
 141             end;
 142          elsif First.Str.all = "quote" then
 143             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 144             return Ast.Sequence.all.Data (2);
 145          elsif First.Str.all = "def!" then
 146             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 147             declare
 148                Key : Types.T renames Ast.Sequence.all.Data (2);
 149                Val : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
 150             begin
 151                Env.all.Set (Key, Val); --  Check key kind.
 152                return Val;
 153             end;
 154          elsif First.Str.all = "defmacro!" then
 155             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 156             declare
 157                Key : Types.T renames Ast.Sequence.all.Data (2);
 158                Fun : constant Types.T := Eval (Ast.Sequence.all.Data (3), Env);
 159                Val : Types.T;
 160             begin
 161                Err.Check (Fun.Kind = Kind_Fn, "expected a function");
 162                Val := Types.Macros.New_Macro (Fun.Fn.all);
 163                Env.all.Set (Key, Val);  --  Check key kind.
 164                return Val;
 165             end;
 166          --  do is a built-in function, shortening this test cascade.
 167          elsif First.Str.all = "fn*" then
 168             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 169             declare
 170                Params : Types.T renames Ast.Sequence.all.Data (2);
 171             begin
 172                Err.Check (Params.Kind in Types.Kind_Sequence,
 173                           "first argument of fn* must be a sequence");
 174                Env_Reusable := False;
 175                return Types.Fns.New_Function
 176                  (Params => Params.Sequence,
 177                   Ast    => Ast.Sequence.all.Data (3),
 178                   Env    => Env);
 179             end;
 180          elsif First.Str.all = "macroexpand" then
 181             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 182             Macroexpanding := True;
 183             Ast := Ast.Sequence.all.Data (2);
 184             goto Restart;
 185          elsif First.Str.all = "quasiquote" then
 186             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 187             return Quasiquote (Ast.Sequence.all.Data (2), Env);
 188          else
 189             --  Equivalent to First := Eval (First, Env)
 190             --  except that we already know enough to spare a recursive call.
 191             First := Env.all.Get (First.Str);
 192          end if;
 193       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
 194         | Kind_Macro | Types.Kind_Function =>
 195          --  Equivalent to First := Eval (First, Env)
 196          --  except that we already know enough to spare a recursive call.
 197          null;
 198       when Types.Kind_Sequence | Kind_Map =>
 199          --  Lists are definitely worth a recursion, and the two other
 200          --  cases should be rare (they will report an error later).
 201          First := Eval (First, Env);
 202       end case;
 203
 204       --  Apply phase.
 205       --  Ast is a non-empty list,
 206       --  First is its non-special evaluated first element.
 207       case First.Kind is
 208       when Kind_Macro =>
 209          --  Use the unevaluated arguments.
 210          if Macroexpanding then
 211             --  Evaluate the macro with tail call optimization.
 212             if not Env_Reusable then
 213                Env := Envs.New_Env (Outer => Env);
 214                Env_Reusable := True;
 215             end if;
 216             Env.all.Set_Binds
 217               (Binds => First.Macro.all.Params.all.Data,
 218                Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
 219             Ast := First.Macro.all.Ast;
 220             goto Restart;
 221          else
 222             --  Evaluate the macro normally.
 223             declare
 224                New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
 225             begin
 226                New_Env.all.Set_Binds
 227                  (Binds => First.Macro.all.Params.all.Data,
 228                   Exprs => Ast.Sequence.all.Data
 229                     (2 .. Ast.Sequence.all.Length));
 230                Ast := Eval (First.Macro.all.Ast, New_Env);
 231                --  Then evaluate the result with TCO.
 232                goto Restart;
 233             end;
 234          end if;
 235       when Types.Kind_Function =>
 236          null;
 237       when others =>
 238          Err.Raise_With ("first element must be a function or macro");
 239       end case;
 240       --  We are applying a function. Evaluate its arguments.
 241       declare
 242          Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
 243       begin
 244          for I in Args'Range loop
 245             Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
 246          end loop;
 247          if First.Kind = Kind_Builtin then
 248             return First.Builtin.all (Args);
 249          end if;
 250          --  Like Types.Fns.Apply, except that we use TCO.
 251          Env := Envs.New_Env (Outer => First.Fn.all.Env);
 252          Env_Reusable := True;
 253          Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
 254                             Exprs => Args);
 255          Ast := First.Fn.all.Ast;
 256          goto Restart;
 257       end;
 258    exception
 259       when Err.Error =>
 260          if Macroexpanding then
 261             Err.Add_Trace_Line ("macroexpand", Ast);
 262          else
 263             Err.Add_Trace_Line ("eval", Ast);
 264          end if;
 265          raise;
 266    end Eval;
 267
 268    function Eval_Map (Source : in Types.Maps.Instance;
 269                       Env    : in Envs.Ptr) return Types.T
 270    is
 271       use all type Types.Maps.Cursor;
 272       --  Copy the whole map so that keys are not hashed again.
 273       Result   : constant Types.T  := Types.Maps.New_Map (Source);
 274       Position : Types.Maps.Cursor := Result.Map.all.First;
 275    begin
 276       while Has_Element (Position) loop
 277          Result.Map.all.Replace_Element (Position,
 278                                          Eval (Element (Position), Env));
 279          Next (Position);
 280       end loop;
 281       return Result;
 282    end Eval_Map;
 283
 284    function Eval_Vector (Source : in Types.Sequences.Instance;
 285                          Env    : in Envs.Ptr) return Types.T
 286    is
 287       Ref : constant Types.Sequence_Ptr
 288         := Types.Sequences.Constructor (Source.Length);
 289    begin
 290       for I in Source.Data'Range loop
 291          Ref.all.Data (I) := Eval (Source.Data (I), Env);
 292       end loop;
 293       return (Kind_Vector, Ref);
 294    end Eval_Vector;
 295
 296    procedure Exec (Script : in String;
 297                    Env    : in Envs.Ptr)
 298    is
 299       Result : Types.T;
 300    begin
 301       for Expression of Reader.Read_Str (Script) loop
 302          Result := Eval (Expression, Env);
 303       end loop;
 304       pragma Unreferenced (Result);
 305    end Exec;
 306
 307    procedure Print (Ast : in Types.T) is
 308    begin
 309       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
 310    end Print;
 311
 312    function Quasiquote (Ast : in Types.T;
 313                         Env : in Envs.Ptr) return Types.T
 314    is
 315
 316       function Quasiquote_List (List : in Types.T_Array) return Types.T;
 317       --  Handle vectors and lists not starting with unquote.
 318
 319       function Quasiquote_List (List : in Types.T_Array) return Types.T is
 320          Vector : Vectors.Vector; --  buffer for concatenation
 321          Tmp    : Types.T;
 322       begin
 323          for Elt of List loop
 324             if Elt.Kind in Kind_List
 325               and then 0 < Elt.Sequence.all.Length
 326               and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
 327               and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
 328             then
 329                Err.Check (Elt.Sequence.all.Length = 2,
 330                           "splice-unquote expects 1 parameter");
 331                Tmp := Eval (Elt.Sequence.all.Data (2), Env);
 332                Err.Check (Tmp.Kind = Kind_List,
 333                           "splice_unquote expects a list");
 334                for Sub_Elt of Tmp.Sequence.all.Data loop
 335                   Vector.Append (Sub_Elt);
 336                end loop;
 337             else
 338                Vector.Append (Quasiquote (Elt, Env));
 339             end if;
 340          end loop;
 341          --  Now that we know the number of elements, convert to a list.
 342          declare
 343             Sequence : constant Types.Sequence_Ptr
 344               := Types.Sequences.Constructor (Natural (Vector.Length));
 345          begin
 346             for I in 1 .. Natural (Vector.Length) loop
 347                Sequence.all.Data (I) := Vector (I);
 348             end loop;
 349             return (Kind_List, Sequence);
 350          end;
 351       end Quasiquote_List;
 352
 353    begin                                --  Quasiquote
 354       case Ast.Kind is
 355          when Kind_Vector =>
 356             --  When the test is updated, replace Kind_List with Kind_Vector.
 357             return Quasiquote_List (Ast.Sequence.all.Data);
 358          when Kind_List =>
 359             if 0 < Ast.Sequence.all.Length
 360               and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
 361               and then Ast.Sequence.all.Data (1).Str.all = "unquote"
 362             then
 363                Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 364                return Eval (Ast.Sequence.all.Data (2), Env);
 365             else
 366                return Quasiquote_List (Ast.Sequence.all.Data);
 367             end if;
 368          when others =>
 369             return Ast;
 370       end case;
 371    exception
 372       when Err.Error =>
 373          Err.Add_Trace_Line ("quasiquote", Ast);
 374          raise;
 375    end Quasiquote;
 376
 377    function Read return Types.T_Array
 378    is (Reader.Read_Str (Readline.Input ("user> ")));
 379
 380    procedure Rep (Env : in Envs.Ptr) is
 381    begin
 382       for Expression of Read loop
 383          Print (Eval (Expression, Env));
 384       end loop;
 385    end Rep;
 386
 387    ----------------------------------------------------------------------
 388
 389    Startup : constant String
 390      := "(def! not (fn* (a) (if a false true)))"
 391      & "(def! load-file (fn* (f)"
 392      & "  (eval (read-string (str ""(do "" (slurp f) "")"")))))"
 393      & "(defmacro! cond (fn* (& xs)"
 394      & "  (if (> (count xs) 0)"
 395      & "    (list 'if (first xs)"
 396      & "      (if (> (count xs) 1) (nth xs 1)"
 397      & "        (throw ""odd number of forms to cond""))"
 398      & "      (cons 'cond (rest (rest xs)))))))"
 399      & "(defmacro! or (fn* (& xs)"
 400      & "  (if (empty? xs) nil"
 401      & "  (if (= 1 (count xs)) (first xs)"
 402      & "  `(let* (or_FIXME ~(first xs))"
 403      & "      (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
 404    Repl : constant Envs.Ptr := Envs.New_Env;
 405    function Eval_Builtin (Args : in Types.T_Array) return Types.T is
 406    begin
 407       Err.Check (Args'Length = 1, "expected 1 parameter");
 408       return Eval (Args (Args'First), Repl);
 409    end Eval_Builtin;
 410    Script : constant Boolean := 0 < ACL.Argument_Count;
 411    Argv   : constant Types.Sequence_Ptr
 412      := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
 413 begin
 414    --  Show the Eval function to other packages.
 415    Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
 416    --  Add Core functions into the top environment.
 417    Core.NS_Add_To_Repl (Repl);
 418    Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
 419                  (Kind_Builtin, Eval_Builtin'Unrestricted_Access));
 420    --  Native startup procedure.
 421    Exec (Startup, Repl);
 422    --  Define ARGV from command line arguments.
 423    for I in 2 .. ACL.Argument_Count loop
 424       Argv.all.Data (I - 1) := (Kind_String,
 425                                 Types.Strings.Alloc (ACL.Argument (I)));
 426    end loop;
 427    Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
 428                  (Kind_List, Argv));
 429    --  Execute user commands.
 430    if Script then
 431       Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
 432    else
 433       loop
 434          begin
 435             Rep (Repl);
 436          exception
 437             when Readline.End_Of_File =>
 438                exit;
 439             when Err.Error =>
 440                Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
 441          end;
 442          --  Other exceptions are really unexpected.
 443
 444          --  Collect garbage.
 445          Err.Data := Types.Nil;
 446          Repl.all.Keep;
 447          Garbage_Collected.Clean;
 448       end loop;
 449       Ada.Text_IO.New_Line;
 450    end if;
 451
 452    --  If assertions are enabled, check deallocations.
 453    --  Normal runs do not need to deallocate before termination.
 454    --  Beware that all pointers are now dangling.
 455    pragma Debug (Garbage_Collected.Clean);
 456    Garbage_Collected.Check_Allocations;
 457 end Step8_Macros;