impls/ada/step9_try.adb

   1 with Ada.Command_Line;
   2 with Ada.Exceptions;
   3 with Ada.Text_IO;
   4 with Core;
   5 with Envs;
   6 with Eval_Callback;
   7 with Printer;
   8 with Reader;
   9 with Smart_Pointers;
  10 with Types;
  11
  12 procedure Step9_Try is
  13
  14    use Types;
  15
  16    function Eval (AParam : Types.Mal_Handle; AnEnv : Envs.Env_Handle)
  17    return Types.Mal_Handle;
  18
  19    Debug : Boolean := False;
  20
  21
  22    function Read (Param : String) return Types.Mal_Handle is
  23    begin
  24       return Reader.Read_Str (Param);
  25    end Read;
  26
  27
  28    function Def_Fn (Args : List_Mal_Type; Env : Envs.Env_Handle)
  29                    return Mal_Handle is
  30       Name, Fn_Body, Res : Mal_Handle;
  31    begin
  32       Name := Car (Args);
  33       pragma Assert (Deref (Name).Sym_Type = Sym,
  34                      "Def_Fn: expected atom as name");
  35       Fn_Body := Nth (Args, 1);
  36       Res := Eval (Fn_Body, Env);
  37       Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
  38       return Res;
  39    end Def_Fn;
  40
  41
  42    function Def_Macro (Args : List_Mal_Type; Env : Envs.Env_Handle)
  43                    return Mal_Handle is
  44       Name, Fn_Body, Res : Mal_Handle;
  45       Lambda_P : Lambda_Ptr;
  46    begin
  47       Name := Car (Args);
  48       pragma Assert (Deref (Name).Sym_Type = Sym,
  49                      "Def_Macro: expected atom as name");
  50       Fn_Body := Car (Deref_List (Cdr (Args)).all);
  51       Res := Eval (Fn_Body, Env);
  52       Lambda_P := Deref_Lambda (Res);
  53       Lambda_P.Set_Is_Macro (True);
  54       Envs.Set (Env, Deref_Sym (Name).Get_Sym, Res);
  55       return Res;
  56    end Def_Macro;
  57
  58
  59    function Macro_Expand (Ast : Mal_Handle; Env : Envs.Env_Handle)
  60    return Mal_Handle is
  61       Res : Mal_Handle;
  62       E : Envs.Env_Handle;
  63       LMT : List_Mal_Type;
  64       LP : Lambda_Ptr;
  65    begin
  66
  67       Res := Ast;
  68       E := Env;
  69
  70       loop
  71
  72          if Deref (Res).Sym_Type /= List then
  73             exit;
  74          end if;
  75
  76          LMT := Deref_List (Res).all;
  77
  78          -- Get the macro in the list from the env
  79          -- or return null if not applicable.
  80          LP := Get_Macro (Res, E);
  81
  82       exit when LP = null or else not LP.Get_Is_Macro;
  83
  84           declare
  85              Fn_List : Mal_Handle := Cdr (LMT);
  86              Params : List_Mal_Type;
  87           begin
  88              E := Envs.New_Env (E);
  89
  90              Params := Deref_List (LP.Get_Params).all;
  91              if Envs.Bind (E, Params, Deref_List (Fn_List).all) then
  92
  93                 Res := Eval (LP.Get_Expr, E);
  94
  95              end if;
  96
  97           end;
  98
  99       end loop;
 100
 101       return Res;
 102
 103    end Macro_Expand;
 104
 105
 106    function Eval_As_Boolean (MH : Mal_Handle) return Boolean is
 107       Res : Boolean;
 108    begin
 109       case Deref (MH).Sym_Type is
 110          when Bool =>
 111             Res := Deref_Bool (MH).Get_Bool;
 112          when Nil =>
 113             return False;
 114 --         when List =>
 115 --            declare
 116 --               L : List_Mal_Type;
 117 --            begin
 118 --               L := Deref_List (MH).all;
 119 --               Res := not Is_Null (L);
 120 --            end;
 121          when others => -- Everything else
 122             Res := True;
 123       end case;
 124       return Res;
 125    end Eval_As_Boolean;
 126
 127
 128    function Eval_Ast
 129      (Ast : Mal_Handle; Env : Envs.Env_Handle)
 130      return Mal_Handle is
 131
 132       function Call_Eval (A : Mal_Handle) return Mal_Handle is
 133       begin
 134          return Eval (A, Env);
 135       end Call_Eval;
 136
 137    begin
 138
 139       case Deref (Ast).Sym_Type is
 140
 141          when Sym =>
 142
 143             declare
 144                Sym : Mal_String := Deref_Sym (Ast).Get_Sym;
 145             begin
 146                -- if keyword, return it. Otherwise look it up in the environment.
 147                if Sym(1) = ':' then
 148                   return Ast;
 149                else
 150                   return Envs.Get (Env, Sym);
 151                end if;
 152             exception
 153                when Envs.Not_Found =>
 154                   raise Envs.Not_Found with ("'" &  Sym & "' not found");
 155             end;
 156
 157          when List =>
 158
 159             return Map (Call_Eval'Unrestricted_Access, Deref_List_Class (Ast).all);
 160
 161          when others => return Ast;
 162
 163       end case;
 164
 165    end Eval_Ast;
 166
 167    function Starts_With (Ast : Mal_Handle; Symbol : String) return Boolean is
 168       A0 : Mal_Handle;
 169    begin
 170       if Deref (Ast).Sym_Type /= List
 171         or else Deref_List_Class (Ast).Get_List_Type /= List_List
 172         or else Deref_List (Ast).Is_Null
 173       then
 174          return False;
 175       end if;
 176       A0 := Deref_List (Ast).Car;
 177       return Deref (A0).Sym_Type = Sym
 178         and then Deref_Sym (A0).Get_Sym = Symbol;
 179    end Starts_With;
 180
 181    function Quasi_Quote_Processing (Param : Mal_Handle) return Mal_Handle is
 182       Res, Elt, New_Res : Mal_Handle;
 183       L : List_Ptr;
 184    begin
 185
 186       if Debug then
 187          Ada.Text_IO.Put_Line ("QuasiQt " & Deref (Param).To_String);
 188       end if;
 189
 190       if Deref (Param).Sym_Type not in Sym | List then
 191          --  No need to quote, Eval would not affect these anyway.
 192          return Param;
 193       end if;
 194
 195       if Deref (Param).Sym_Type /= List or else
 196         Deref_List_Class (Param).Get_List_Type = Hashed_List then
 197
 198          -- return a new list containing: a symbol named "quote" and ast.
 199          Res := New_List_Mal_Type (List_List);
 200          L := Deref_List (Res);
 201          L.Append (New_Symbol_Mal_Type ("quote"));
 202          L.Append (Param);
 203          return Res;
 204
 205       end if;
 206
 207       -- if the first element of ast is a symbol named "unquote":
 208       if Starts_With (Param, "unquote") then
 209          -- return the second element of ast.`
 210          return Deref_List_Class (Param).Nth (1);
 211
 212       end if;
 213
 214       Res := New_List_Mal_Type (List_List);
 215
 216       for I in reverse 0 .. Deref_List_Class (Param).Length - 1 loop
 217          Elt := Deref_List_Class (Param).Nth (I);
 218          New_Res := New_List_Mal_Type (List_List);
 219          L := Deref_List (New_Res);
 220          if Starts_With (Elt, "splice-unquote") then
 221             L.Append (New_Symbol_Mal_Type ("concat"));
 222             L.Append (Deref_List (Elt).Nth (1));
 223          else
 224             L.Append (New_Symbol_Mal_Type ("cons"));
 225             L.Append (Quasi_Quote_Processing (Elt));
 226          end if;
 227          L.Append (Res);
 228          Res := New_Res;
 229       end loop;
 230
 231       if Deref_List_Class (Param).Get_List_Type = Vector_List then
 232          New_Res := New_List_Mal_Type (List_List);
 233          L := Deref_List (New_Res);
 234          L.Append (New_Symbol_Mal_Type ("vec"));
 235          L.Append (Res);
 236          Res := New_Res;
 237       end if;
 238
 239       return Res;
 240
 241    end Quasi_Quote_Processing;
 242
 243
 244    function Catch_Processing
 245               (Try_Line : Mal_Handle;
 246                ExStr : Mal_Handle;
 247                Env : Envs.Env_Handle)
 248    return Mal_Handle is
 249
 250       L, CL, CL2, CL3 : List_Mal_Type;
 251       C : Mal_Handle;
 252       New_Env : Envs.Env_Handle;
 253
 254    begin
 255
 256       L := Deref_List (Try_Line).all;
 257       C := Car (L);
 258       -- CL is the list with the catch in.
 259       CL := Deref_List (C).all;
 260
 261       CL2 := Deref_List (Cdr (CL)).all;
 262       New_Env := Envs.New_Env (Env);
 263       Envs.Set (New_Env, Deref_Sym (Car (CL2)).Get_Sym, ExStr);
 264
 265       CL3 := Deref_List (Cdr (CL2)).all;
 266       return Eval (Car (CL3), New_Env);
 267    end Catch_Processing;
 268
 269
 270    function Eval (AParam : Mal_Handle; AnEnv : Envs.Env_Handle)
 271                  return Mal_Handle is
 272       Param : Mal_Handle;
 273       Env : Envs.Env_Handle;
 274       First_Param, Rest_Params : Mal_Handle;
 275       Rest_List, Param_List : List_Mal_Type;
 276    begin
 277
 278       Param := AParam;
 279       Env := AnEnv;
 280
 281       <<Tail_Call_Opt>>
 282
 283       if Debug then
 284          Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
 285       end if;
 286
 287       Param := Macro_Expand (Param, Env);
 288
 289       if Debug then
 290          Ada.Text_IO.Put_Line ("After expansion " & Deref (Param).To_String);
 291       end if;
 292
 293       if Deref (Param).Sym_Type = List and then
 294         Deref_List (Param).Get_List_Type = List_List then
 295
 296          Param_List := Deref_List (Param).all;
 297
 298          -- Deal with empty list..
 299          if Param_List.Length = 0 then
 300             return Param;
 301          end if;
 302
 303          First_Param := Car (Param_List);
 304          Rest_Params := Cdr (Param_List);
 305          Rest_List := Deref_List (Rest_Params).all;
 306
 307          if Deref (First_Param).Sym_Type = Sym and then
 308             Deref_Sym (First_Param).Get_Sym = "def!" then
 309             return Def_Fn (Rest_List, Env);
 310          elsif Deref (First_Param).Sym_Type = Sym and then
 311                Deref_Sym (First_Param).Get_Sym = "defmacro!" then
 312             return Def_Macro (Rest_List, Env);
 313          elsif Deref (First_Param).Sym_Type = Sym and then
 314                Deref_Sym (First_Param).Get_Sym = "macroexpand" then
 315             return Macro_Expand (Car (Rest_List), Env);
 316          elsif Deref (First_Param).Sym_Type = Sym and then
 317                Deref_Sym (First_Param).Get_Sym = "let*" then
 318             declare
 319                Defs, Expr, Res : Mal_Handle;
 320                E : Envs.Env_Handle;
 321             begin
 322                E := Envs.New_Env (Env);
 323                Defs := Car (Rest_List);
 324                Deref_List_Class (Defs).Add_Defs (E);
 325                Expr := Car (Deref_List (Cdr (Rest_List)).all);
 326                Param := Expr;
 327                Env := E;
 328                goto Tail_Call_Opt;
 329                -- was:
 330                -- Res := Eval (Expr, E);
 331                -- return Res;
 332             end;
 333          elsif Deref (First_Param).Sym_Type = Sym and then
 334                Deref_Sym (First_Param).Get_Sym = "do" then
 335             declare
 336                D : List_Mal_Type;
 337                E : Mal_Handle;
 338             begin
 339
 340                if Debug then
 341                   Ada.Text_IO.Put_Line ("Do-ing " & To_String (Rest_List));
 342                end if;
 343
 344                if Is_Null (Rest_List) then
 345                   return Rest_Params;
 346                end if;
 347
 348                -- Loop processes Evals all but last entry
 349                D := Rest_List;
 350                loop
 351                   E := Car (D);
 352                   D := Deref_List (Cdr (D)).all;
 353                exit when Is_Null (D);
 354                   E := Eval (E, Env);
 355                end loop;
 356
 357                Param := E;
 358                goto Tail_Call_Opt;
 359
 360             end;
 361          elsif Deref (First_Param).Sym_Type = Sym and then
 362                Deref_Sym (First_Param).Get_Sym = "if" then
 363             declare
 364                Args : List_Mal_Type := Rest_List;
 365
 366                Cond, True_Part, False_Part : Mal_Handle;
 367                Cond_Bool : Boolean;
 368                pragma Assert (Length (Args) = 2 or Length (Args) = 3,
 369                               "If_Processing: not 2 or 3 parameters");
 370                L : List_Mal_Type;
 371             begin
 372
 373                Cond := Eval (Car (Args), Env);
 374
 375                Cond_Bool := Eval_As_Boolean (Cond);
 376
 377                if Cond_Bool then
 378                   L := Deref_List (Cdr (Args)).all;
 379
 380                   Param := Car (L);
 381                   goto Tail_Call_Opt;
 382                   -- was: return Eval (Car (L), Env);
 383                else
 384                   if Length (Args) = 3 then
 385                      L := Deref_List (Cdr (Args)).all;
 386                      L := Deref_List (Cdr (L)).all;
 387
 388                      Param := Car (L);
 389                      goto Tail_Call_Opt;
 390                      -- was: return Eval (Car (L), Env);
 391                   else
 392                      return New_Nil_Mal_Type;
 393                   end if;
 394                end if;
 395             end;
 396
 397          elsif Deref (First_Param).Sym_Type = Sym and then
 398                Deref_Sym (First_Param).Get_Sym = "fn*" then
 399
 400             return New_Lambda_Mal_Type
 401                      (Params => Car (Rest_List),
 402                       Expr => Nth (Rest_List, 1),
 403                       Env => Env);
 404
 405          elsif Deref (First_Param).Sym_Type = Sym and then
 406                Deref_Sym (First_Param).Get_Sym = "quote" then
 407
 408             return Car (Rest_List);
 409
 410          elsif Deref (First_Param).Sym_Type = Sym and then
 411                Deref_Sym (First_Param).Get_Sym = "quasiquoteexpand" then
 412
 413             return Quasi_Quote_Processing (Car (Rest_List));
 414
 415          elsif Deref (First_Param).Sym_Type = Sym and then
 416                Deref_Sym (First_Param).Get_Sym = "quasiquote" then
 417
 418             Param := Quasi_Quote_Processing (Car (Rest_List));
 419             goto Tail_Call_Opt;
 420
 421          elsif Deref (First_Param).Sym_Type = Sym and then
 422                Deref_Sym (First_Param).Get_Sym = "try*" then
 423
 424             if Length (Rest_List) = 1 then
 425                return Eval (Car (Rest_List), Env);
 426             end if;
 427             declare
 428                Res : Mal_Handle;
 429             begin
 430                return Eval (Car (Rest_List), Env);
 431             exception
 432                when Mal_Exception =>
 433                   Res := Catch_Processing
 434                            (Cdr (Rest_List),
 435                             Types.Mal_Exception_Value,
 436                             Env);
 437                   Types.Mal_Exception_Value :=
 438                     Smart_Pointers.Null_Smart_Pointer;
 439                   return Res;
 440                when E : others =>
 441                   return Catch_Processing
 442                            (Cdr (Rest_List),
 443                             New_String_Mal_Type
 444                               (Ada.Exceptions.Exception_Message (E)),
 445                             Env);
 446             end;
 447
 448          else
 449
 450             -- The APPLY section.
 451             declare
 452                Evaled_H : Mal_Handle;
 453             begin
 454                Evaled_H := Eval_Ast (Param, Env);
 455
 456                Param_List := Deref_List (Evaled_H).all;
 457
 458                First_Param := Car (Param_List);
 459                Rest_Params := Cdr (Param_List);
 460                Rest_List := Deref_List (Rest_Params).all;
 461
 462                if Deref (First_Param).Sym_Type = Func then
 463                   return Call_Func (Deref_Func (First_Param).all, Rest_Params);
 464                elsif Deref (First_Param).Sym_Type = Lambda then
 465                   declare
 466
 467                      L : Lambda_Mal_Type;
 468                      E : Envs.Env_Handle;
 469                      Param_Names : List_Mal_Type;
 470                      Res : Mal_Handle;
 471
 472                   begin
 473
 474                      L := Deref_Lambda (First_Param).all;
 475                      E := Envs.New_Env (L.Get_Env);
 476
 477                      Param_Names := Deref_List (L.Get_Params).all;
 478
 479                      if Envs.Bind (E, Param_Names, Deref_List (Rest_Params).all) then
 480
 481                         Param := L.Get_Expr;
 482                         Env := E;
 483                         goto Tail_Call_Opt;
 484                         -- was: return Eval (L.Get_Expr, E);
 485
 486                      else
 487
 488                         raise Runtime_Exception with "Bind failed in Apply";
 489
 490                      end if;
 491
 492                   end;
 493
 494                else  -- neither a Lambda or a Func
 495                   raise Runtime_Exception with "Deref called on non-Func/Lambda";
 496                end if;
 497
 498             end;
 499
 500          end if;
 501
 502       else -- not a List_List
 503
 504          return Eval_Ast (Param, Env);
 505
 506       end if;
 507
 508    end Eval;
 509
 510
 511    function Print (Param : Types.Mal_Handle) return String is
 512    begin
 513       return Printer.Pr_Str (Param);
 514    end Print;
 515
 516    function Rep (Param : String; Env : Envs.Env_Handle) return String is
 517       AST, Evaluated_AST : Types.Mal_Handle;
 518    begin
 519
 520       AST := Read (Param);
 521
 522       if Types.Is_Null (AST) then
 523          return "";
 524       else
 525          Evaluated_AST := Eval (AST, Env);
 526          return Print (Evaluated_AST);
 527       end if;
 528
 529    end Rep;
 530
 531
 532    Repl_Env : Envs.Env_Handle;
 533
 534
 535    -- These two ops use Repl_Env directly.
 536
 537
 538    procedure RE (Str : Mal_String) is
 539       Discarded : Mal_Handle;
 540    begin
 541       Discarded := Eval (Read (Str), Repl_Env);
 542    end RE;
 543
 544
 545    function Do_Eval (Rest_Handle : Mal_Handle)
 546    return Types.Mal_Handle is
 547       First_Param : Mal_Handle;
 548       Rest_List : Types.List_Mal_Type;
 549    begin
 550       Rest_List := Deref_List (Rest_Handle).all;
 551       First_Param := Car (Rest_List);
 552       return Eval_Callback.Eval.all (First_Param, Repl_Env);
 553    end Do_Eval;
 554
 555
 556    Cmd_Args, File_Param : Natural;
 557    Command_Args : Types.Mal_Handle;
 558    Command_List : Types.List_Ptr;
 559    File_Processed : Boolean := False;
 560
 561 begin
 562
 563    -- Save a function pointer back to the Eval function.
 564    -- Can't use 'Access here because of Ada rules but 'Unrestricted_Access is OK
 565    -- as we know Eval will be in scope for the lifetime of the program.
 566    Eval_Callback.Eval := Eval'Unrestricted_Access;
 567
 568    Repl_Env := Envs.New_Env;
 569
 570    -- Core init also creates the first environment.
 571    -- This is needed for the def!'s below.
 572    Core.Init (Repl_Env);
 573
 574    -- Register the eval command.  This needs to be done here rather than Core.Init
 575    -- as it requires direct access to Repl_Env.
 576    Envs.Set (Repl_Env, "eval", New_Func_Mal_Type ("eval", Do_Eval'Unrestricted_Access));
 577
 578    RE ("(def! not (fn* (a) (if a false true)))");
 579    RE ("(def! load-file (fn* (f) (eval (read-string (str ""(do "" (slurp f) ""\nnil)"")))))");
 580    RE ("(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list 'if (first xs) (if (> (count xs) 1) (nth xs 1) (throw ""odd number of forms to cond"")) (cons 'cond (rest (rest xs)))))))");
 581
 582    -- Command line processing.
 583
 584    Cmd_Args := 0;
 585    Command_Args := Types.New_List_Mal_Type (Types.List_List);
 586    Command_List := Types.Deref_List (Command_Args);
 587
 588    while Ada.Command_Line.Argument_Count > Cmd_Args loop
 589
 590      Cmd_Args := Cmd_Args + 1;
 591      if Ada.Command_Line.Argument (Cmd_Args) = "-d" then
 592         Debug := True;
 593      elsif Ada.Command_Line.Argument (Cmd_Args) = "-e" then
 594         Envs.Debug := True;
 595      elsif not File_Processed then
 596         File_Param := Cmd_Args;
 597         File_Processed := True;
 598      else
 599         Command_List.Append
 600           (Types.New_String_Mal_Type (Ada.Command_Line.Argument (Cmd_Args)));
 601      end if;
 602
 603    end loop;
 604
 605    Envs.Set (Repl_Env, "*ARGV*", Command_Args);
 606
 607    if File_Processed then
 608       RE ("(load-file """ & Ada.Command_Line.Argument (File_Param) & """)");
 609    else
 610       loop
 611          begin
 612             Ada.Text_IO.Put ("user> ");
 613             exit when Ada.Text_IO.End_Of_File;
 614             Ada.Text_IO.Put_Line (Rep (Ada.Text_IO.Get_Line, Repl_Env));
 615          exception
 616             when E : others =>
 617                Ada.Text_IO.Put_Line
 618                  (Ada.Text_IO.Standard_Error,
 619                   "Error: " & Ada.Exceptions.Exception_Information (E));
 620                if Types.Mal_Exception_Value /= Smart_Pointers.Null_Smart_Pointer then
 621                   Ada.Text_IO.Put_Line
 622                     (Ada.Text_IO.Standard_Error,
 623                      Printer.Pr_Str (Types.Mal_Exception_Value));
 624                   Types.Mal_Exception_Value := Smart_Pointers.Null_Smart_Pointer;
 625                end if;
 626          end;
 627       end loop;
 628    end if;
 629 end Step9_Try;