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          elsif First.Str.all = "do" then
 167             Err.Check (1 < Ast.Sequence.all.Length, "do expects arguments");
 168             declare
 169                Result : Types.T;
 170             begin
 171                for I in 2 .. Ast.Sequence.all.Length loop
 172                   Result := Eval (Ast.Sequence.all.Data (I), Env);
 173                end loop;
 174                return Result;
 175             end;
 176          elsif First.Str.all = "fn*" then
 177             Err.Check (Ast.Sequence.all.Length = 3, "expected 2 parameters");
 178             declare
 179                Params : Types.T renames Ast.Sequence.all.Data (2);
 180             begin
 181                Err.Check (Params.Kind in Types.Kind_Sequence,
 182                           "first argument of fn* must be a sequence");
 183                Env_Reusable := False;
 184                return Types.Fns.New_Function
 185                  (Params => Params.Sequence,
 186                   Ast    => Ast.Sequence.all.Data (3),
 187                   Env    => Env);
 188             end;
 189          elsif First.Str.all = "macroexpand" then
 190             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 191             Macroexpanding := True;
 192             Ast := Ast.Sequence.all.Data (2);
 193             goto Restart;
 194          elsif First.Str.all = "quasiquote" then
 195             Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 196             return Quasiquote (Ast.Sequence.all.Data (2), Env);
 197          else
 198             --  Equivalent to First := Eval (First, Env)
 199             --  except that we already know enough to spare a recursive call.
 200             First := Env.all.Get (First.Str);
 201          end if;
 202       when Kind_Nil | Kind_Atom | Kind_Boolean | Kind_Number | Types.Kind_Key
 203         | Kind_Macro | Types.Kind_Function =>
 204          --  Equivalent to First := Eval (First, Env)
 205          --  except that we already know enough to spare a recursive call.
 206          null;
 207       when Types.Kind_Sequence | Kind_Map =>
 208          --  Lists are definitely worth a recursion, and the two other
 209          --  cases should be rare (they will report an error later).
 210          First := Eval (First, Env);
 211       end case;
 212
 213       --  Apply phase.
 214       --  Ast is a non-empty list,
 215       --  First is its non-special evaluated first element.
 216       case First.Kind is
 217       when Kind_Macro =>
 218          --  Use the unevaluated arguments.
 219          if Macroexpanding then
 220             --  Evaluate the macro with tail call optimization.
 221             if not Env_Reusable then
 222                Env := Envs.New_Env (Outer => Env);
 223                Env_Reusable := True;
 224             end if;
 225             Env.all.Set_Binds
 226               (Binds => First.Macro.all.Params.all.Data,
 227                Exprs => Ast.Sequence.all.Data (2 .. Ast.Sequence.all.Length));
 228             Ast := First.Macro.all.Ast;
 229             goto Restart;
 230          else
 231             --  Evaluate the macro normally.
 232             declare
 233                New_Env : constant Envs.Ptr := Envs.New_Env (Outer => Env);
 234             begin
 235                New_Env.all.Set_Binds
 236                  (Binds => First.Macro.all.Params.all.Data,
 237                   Exprs => Ast.Sequence.all.Data
 238                     (2 .. Ast.Sequence.all.Length));
 239                Ast := Eval (First.Macro.all.Ast, New_Env);
 240                --  Then evaluate the result with TCO.
 241                goto Restart;
 242             end;
 243          end if;
 244       when Types.Kind_Function =>
 245          null;
 246       when others =>
 247          Err.Raise_With ("first element must be a function or macro");
 248       end case;
 249       --  We are applying a function. Evaluate its arguments.
 250       declare
 251          Args : Types.T_Array (2 .. Ast.Sequence.all.Length);
 252       begin
 253          for I in Args'Range loop
 254             Args (I) := Eval (Ast.Sequence.all.Data (I), Env);
 255          end loop;
 256          if First.Kind = Kind_Builtin then
 257             return First.Builtin.all (Args);
 258          end if;
 259          --  Like Types.Fns.Apply, except that we use TCO.
 260          Env := Envs.New_Env (Outer => First.Fn.all.Env);
 261          Env_Reusable := True;
 262          Env.all.Set_Binds (Binds => First.Fn.all.Params.all.Data,
 263                             Exprs => Args);
 264          Ast := First.Fn.all.Ast;
 265          goto Restart;
 266       end;
 267    exception
 268       when Err.Error =>
 269          if Macroexpanding then
 270             Err.Add_Trace_Line ("macroexpand", Ast);
 271          else
 272             Err.Add_Trace_Line ("eval", Ast);
 273          end if;
 274          raise;
 275    end Eval;
 276
 277    function Eval_Map (Source : in Types.Maps.Instance;
 278                       Env    : in Envs.Ptr) return Types.T
 279    is
 280       use all type Types.Maps.Cursor;
 281       --  Copy the whole map so that keys are not hashed again.
 282       Result   : constant Types.T  := Types.Maps.New_Map (Source);
 283       Position : Types.Maps.Cursor := Result.Map.all.First;
 284    begin
 285       while Has_Element (Position) loop
 286          Result.Map.all.Replace_Element (Position,
 287                                          Eval (Element (Position), Env));
 288          Next (Position);
 289       end loop;
 290       return Result;
 291    end Eval_Map;
 292
 293    function Eval_Vector (Source : in Types.Sequences.Instance;
 294                          Env    : in Envs.Ptr) return Types.T
 295    is
 296       Ref : constant Types.Sequence_Ptr
 297         := Types.Sequences.Constructor (Source.Length);
 298    begin
 299       for I in Source.Data'Range loop
 300          Ref.all.Data (I) := Eval (Source.Data (I), Env);
 301       end loop;
 302       return (Kind_Vector, Ref);
 303    end Eval_Vector;
 304
 305    procedure Exec (Script : in String;
 306                    Env    : in Envs.Ptr)
 307    is
 308       Result : Types.T;
 309    begin
 310       for Expression of Reader.Read_Str (Script) loop
 311          Result := Eval (Expression, Env);
 312       end loop;
 313       pragma Unreferenced (Result);
 314    end Exec;
 315
 316    procedure Print (Ast : in Types.T) is
 317    begin
 318       Ada.Text_IO.Unbounded_IO.Put_Line (Printer.Pr_Str (Ast));
 319    end Print;
 320
 321    function Quasiquote (Ast : in Types.T;
 322                         Env : in Envs.Ptr) return Types.T
 323    is
 324
 325       function Quasiquote_List (List : in Types.T_Array) return Types.T;
 326       --  Handle vectors and lists not starting with unquote.
 327
 328       function Quasiquote_List (List : in Types.T_Array) return Types.T is
 329          Vector : Vectors.Vector; --  buffer for concatenation
 330          Tmp    : Types.T;
 331       begin
 332          for Elt of List loop
 333             if Elt.Kind in Kind_List
 334               and then 0 < Elt.Sequence.all.Length
 335               and then Elt.Sequence.all.Data (1).Kind = Kind_Symbol
 336               and then Elt.Sequence.all.Data (1).Str.all = "splice-unquote"
 337             then
 338                Err.Check (Elt.Sequence.all.Length = 2,
 339                           "splice-unquote expects 1 parameter");
 340                Tmp := Eval (Elt.Sequence.all.Data (2), Env);
 341                Err.Check (Tmp.Kind = Kind_List,
 342                           "splice_unquote expects a list");
 343                for Sub_Elt of Tmp.Sequence.all.Data loop
 344                   Vector.Append (Sub_Elt);
 345                end loop;
 346             else
 347                Vector.Append (Quasiquote (Elt, Env));
 348             end if;
 349          end loop;
 350          --  Now that we know the number of elements, convert to a list.
 351          declare
 352             Sequence : constant Types.Sequence_Ptr
 353               := Types.Sequences.Constructor (Natural (Vector.Length));
 354          begin
 355             for I in 1 .. Natural (Vector.Length) loop
 356                Sequence.all.Data (I) := Vector (I);
 357             end loop;
 358             return (Kind_List, Sequence);
 359          end;
 360       end Quasiquote_List;
 361
 362    begin                                --  Quasiquote
 363       case Ast.Kind is
 364          when Kind_Vector =>
 365             --  When the test is updated, replace Kind_List with Kind_Vector.
 366             return Quasiquote_List (Ast.Sequence.all.Data);
 367          when Kind_List =>
 368             if 0 < Ast.Sequence.all.Length
 369               and then Ast.Sequence.all.Data (1).Kind = Kind_Symbol
 370               and then Ast.Sequence.all.Data (1).Str.all = "unquote"
 371             then
 372                Err.Check (Ast.Sequence.all.Length = 2, "expected 1 parameter");
 373                return Eval (Ast.Sequence.all.Data (2), Env);
 374             else
 375                return Quasiquote_List (Ast.Sequence.all.Data);
 376             end if;
 377          when others =>
 378             return Ast;
 379       end case;
 380    exception
 381       when Err.Error =>
 382          Err.Add_Trace_Line ("quasiquote", Ast);
 383          raise;
 384    end Quasiquote;
 385
 386    function Read return Types.T_Array
 387    is (Reader.Read_Str (Readline.Input ("user> ")));
 388
 389    procedure Rep (Env : in Envs.Ptr) is
 390    begin
 391       for Expression of Read loop
 392          Print (Eval (Expression, Env));
 393       end loop;
 394    end Rep;
 395
 396    ----------------------------------------------------------------------
 397
 398    Startup : constant String
 399      := "(def! not (fn* (a) (if a false true)))"
 400      & "(def! load-file (fn* (f)"
 401      & "  (eval (read-string (str ""(do "" (slurp f) "")"")))))"
 402      & "(defmacro! cond (fn* (& xs)"
 403      & "  (if (> (count xs) 0)"
 404      & "    (list 'if (first xs)"
 405      & "      (if (> (count xs) 1) (nth xs 1)"
 406      & "        (throw ""odd number of forms to cond""))"
 407      & "      (cons 'cond (rest (rest xs)))))))"
 408      & "(defmacro! or (fn* (& xs)"
 409      & "  (if (empty? xs) nil"
 410      & "  (if (= 1 (count xs)) (first xs)"
 411      & "  `(let* (or_FIXME ~(first xs))"
 412      & "      (if or_FIXME or_FIXME (or ~@(rest xs))))))))";
 413    Repl : constant Envs.Ptr := Envs.New_Env;
 414    function Eval_Builtin (Args : in Types.T_Array) return Types.T is
 415    begin
 416       Err.Check (Args'Length = 1, "expected 1 parameter");
 417       return Eval (Args (Args'First), Repl);
 418    end Eval_Builtin;
 419    Script : constant Boolean := 0 < ACL.Argument_Count;
 420    Argv   : constant Types.Sequence_Ptr
 421      := Types.Sequences.Constructor (Integer'Max (0, ACL.Argument_Count - 1));
 422 begin
 423    --  Show the Eval function to other packages.
 424    Types.Fns.Eval_Cb := Eval'Unrestricted_Access;
 425    --  Add Core functions into the top environment.
 426    Core.NS_Add_To_Repl (Repl);
 427    Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("eval")),
 428                  (Kind_Builtin, Eval_Builtin'Unrestricted_Access));
 429    --  Native startup procedure.
 430    Exec (Startup, Repl);
 431    --  Define ARGV from command line arguments.
 432    for I in 2 .. ACL.Argument_Count loop
 433       Argv.all.Data (I - 1) := (Kind_String,
 434                                 Types.Strings.Alloc (ACL.Argument (I)));
 435    end loop;
 436    Repl.all.Set ((Kind_Symbol, Types.Strings.Alloc ("*ARGV*")),
 437                  (Kind_List, Argv));
 438    --  Execute user commands.
 439    if Script then
 440       Exec ("(load-file """ & ACL.Argument (1) & """)", Repl);
 441    else
 442       loop
 443          begin
 444             Rep (Repl);
 445          exception
 446             when Readline.End_Of_File =>
 447                exit;
 448             when Err.Error =>
 449                Ada.Text_IO.Unbounded_IO.Put (Err.Trace);
 450          end;
 451          --  Other exceptions are really unexpected.
 452
 453          --  Collect garbage.
 454          Err.Data := Types.Nil;
 455          Repl.all.Keep;
 456          Garbage_Collected.Clean;
 457       end loop;
 458       Ada.Text_IO.New_Line;
 459    end if;
 460
 461    --  If assertions are enabled, check deallocations.
 462    --  Normal runs do not need to deallocate before termination.
 463    --  Beware that all pointers are now dangling.
 464    pragma Debug (Garbage_Collected.Clean);
 465    Garbage_Collected.Check_Allocations;
 466 end Step8_Macros;