ada/evaluation.adb

   1 with Ada.Text_IO;
   2 with Envs;
   3 with Smart_Pointers;
   4
   5 package body Evaluation is
   6
   7    use Types;
   8
   9    -- primitive functions on Smart_Pointer,
  10    function "+" is new Op ("+", "+");
  11    function "-" is new Op ("-", "-");
  12    function "*" is new Op ("*", "*");
  13    function "/" is new Op ("/", "/");
  14
  15    function "<" is new Rel_Op ("<", "<");
  16    function "<=" is new Rel_Op ("<=", "<=");
  17    function ">" is new Rel_Op (">", ">");
  18    function ">=" is new Rel_Op (">=", ">=");
  19
  20
  21    procedure Add_Defs (Defs : List_Mal_Type; Env : Envs.Env_Handle) is
  22       D, L : List_Mal_Type;
  23    begin
  24       if Debug then
  25          Ada.Text_IO.Put_Line ("Add_Defs " & To_String (Defs));
  26       end if;
  27       D := Defs;
  28       while not Is_Null (D) loop
  29          L := Deref_List (Cdr (D)).all;
  30          Envs.Set
  31            (Env,
  32             Deref_Atom (Car (D)).Get_Atom,
  33             Eval (Car (L), Env));
  34          D := Deref_List (Cdr(L)).all;
  35       end loop;
  36    end Add_Defs;
  37
  38
  39 --   function Fn_Processing
  40 --     (L : Lambda_Ptr;
  41 --      Fn_List : Mal_Handle;
  42 --      Env : Envs.Env_Handle)
  43 --   return Mal_Handle is
  44 --
  45 --      Params : List_Mal_Type;
  46 --      E : Envs.Env_Handle;
  47 --   begin
  48 --      --  Deal with right associativity...
  49 --      E := Envs.New_Env (Env);
  50 --      Params := Deref_List (L.Get_Params).all;
  51 --      Envs.Bind (E, Params, Deref_List (Fn_List).all);
  52 --      Set_Env (L.all, E);
  53 --
  54 --      return Eval (L.Get_Expr, E);
  55 --
  56 --   end Fn_Processing;
  57 --
  58 --
  59    function Fn_Processing
  60      (L : Lambda_Ptr;
  61       Fn_List : Mal_Handle;
  62       Env : Envs.Env_Handle)
  63    return Mal_Handle is
  64
  65       Params : List_Mal_Type;
  66 --      E : Envs.Env_Handle;
  67       Res : Mal_Handle;
  68    begin
  69       --  Deal with right associativity...
  70       Envs.New_Env;
  71       Params := Deref_List (L.Get_Params).all;
  72       Envs.Bind (Envs.Get_Current, Params, Deref_List (Fn_List).all);
  73       Set_Env (L.all, Envs.Get_Current);
  74
  75       Res := Eval (L.Get_Expr, Envs.Get_Current);
  76       Envs.Delete_Env;
  77       return Res;
  78
  79    end Fn_Processing;
  80
  81
  82    function Apply (Func : Types.Mal_Handle; Params : Types.Mal_Handle)
  83    return Types.Mal_Handle is
  84       use Types;
  85       Args : List_Mal_Type;
  86    begin
  87
  88       Args := Deref_List (Params).all;
  89
  90       if Debug then
  91
  92          Ada.Text_IO.Put_Line
  93            ("Applying " & To_String (Deref (Func).all) &
  94             " to " & Args.To_String);
  95
  96       end if;
  97
  98       case Deref (Func).Sym_Type is
  99
 100          when Atom =>
 101
 102             declare
 103                Atom_P : Types.Atom_Ptr;
 104             begin
 105                Atom_P := Types.Deref_Atom (Func);
 106                if Atom_P.Get_Atom = "+" then
 107                   return Reduce ("+"'Access, Args);
 108                elsif Atom_P.Get_Atom = "-" then
 109                   return Reduce ("-"'Access, Args);
 110                elsif Atom_P.Get_Atom = "*" then
 111                   return Reduce ("*"'Access, Args);
 112                elsif Atom_P.Get_Atom = "/" then
 113                   return Reduce ("/"'Access, Args);
 114                elsif Atom_P.Get_Atom = "<" then
 115                   return Reduce ("<"'Access, Args);
 116                elsif Atom_P.Get_Atom = "<=" then
 117                   return Reduce ("<="'Access, Args);
 118                elsif Atom_P.Get_Atom = ">" then
 119                   return Reduce (">"'Access, Args);
 120                elsif Atom_P.Get_Atom = ">=" then
 121                   return Reduce (">="'Access, Args);
 122                elsif Atom_P.Get_Atom = "=" then
 123                   return Reduce (Types."="'Access, Args);
 124                elsif Atom_P.Get_Atom = "list" then
 125                   return New_List_Mal_Type (The_List => Args);
 126                end if;
 127            end;
 128
 129          when Lambda =>
 130
 131             declare
 132                Lam : Lambda_Ptr;
 133             begin
 134                Lam := Deref_Lambda (Func);
 135                return Fn_Processing (Lam, Params, Lam.Get_Env);
 136             end;
 137
 138          when Error => return Func;
 139
 140          when others => null;
 141
 142       end case;
 143       return Smart_Pointers.Null_Smart_Pointer;
 144    end Apply;
 145
 146
 147    function Def_Fn (Args : Types.List_Mal_Type; Env : Envs.Env_Handle) return Types.Mal_Handle is
 148       use Types;
 149       Name, Fn_Body, Res : Mal_Handle;
 150    begin
 151       Name := Car (Args);
 152       pragma Assert (Deref (Name).Sym_Type = Atom,
 153                      "Def_Fn: expected atom as name");
 154       Fn_Body := Car (Deref_List (Cdr (Args)).all);
 155       Res := Eval (Fn_Body, Env);
 156       Envs.Set (Envs.Get_Current, Deref_Atom (Name).Get_Atom, Res);
 157       return Res;
 158    end Def_Fn;
 159
 160
 161    function Let_Processing (Args : Types.List_Mal_Type; Env : Envs.Env_Handle)
 162    return Types.Mal_Handle is
 163       use Types;
 164       Defs, Expr, Res : Mal_Handle;
 165    begin
 166       Envs.New_Env;
 167       Defs := Car (Args);
 168       Add_Defs (Deref_List (Defs).all, Envs.Get_Current);
 169       Expr := Car (Deref_List (Cdr (Args)).all);
 170       Res := Eval (Expr, Envs.Get_Current);
 171       Envs.Delete_Env;
 172       return Res;
 173    end Let_Processing;
 174
 175
 176    function Eval_As_Boolean (MH : Types.Mal_Handle) return Boolean is
 177       use Types;
 178       Res : Boolean;
 179    begin
 180       case Deref (MH).Sym_Type is
 181          when Bool =>
 182             Res := Deref_Bool (MH).Get_Bool;
 183          when Atom =>
 184             return not (Deref_Atom (MH).Get_Atom = "nil");
 185 --         when List =>
 186 --            declare
 187 --               L : List_Mal_Type;
 188 --            begin
 189 --               L := Deref_List (MH).all;
 190 --               Res := not Is_Null (L);
 191 --            end;
 192          when others => -- Everything else
 193             Res := True;
 194       end case;
 195       return Res;
 196    end Eval_As_Boolean;
 197
 198
 199    function If_Processing (Args : Types.List_Mal_Type; Env : Envs.Env_Handle)
 200    return Types.Mal_Handle is
 201       use Types;
 202       Cond, True_Part, False_Part : Mal_Handle;
 203       Cond_Bool : Boolean;
 204       pragma Assert (Length (Args) = 2 or Length (Args) = 3,
 205                      "If_Processing: not 2 or 3 parameters");
 206       L : List_Mal_Type;
 207    begin
 208
 209       Cond := Eval (Car (Args), Env);
 210
 211       Cond_Bool := Eval_As_Boolean (Cond);
 212
 213       if Cond_Bool then
 214          L := Deref_List (Cdr (Args)).all;
 215          return Eval (Car (L), Env);
 216       else
 217          if Length (Args) = 3 then
 218             L := Deref_List (Cdr (Args)).all;
 219             L := Deref_List (Cdr (L)).all;
 220             return Eval (Car (L), Env);
 221          else
 222             return New_Atom_Mal_Type ("nil");
 223          end if;
 224       end if;
 225    end If_Processing;
 226
 227
 228    function Eval_Ast
 229      (Ast : Types.Mal_Handle; Env : Envs.Env_Handle)
 230    return Types.Mal_Handle is
 231
 232       use Types;
 233       function Call_Eval (A : Mal_Handle) return Mal_Handle is
 234       begin
 235          return Eval (A, Env);
 236       end Call_Eval;
 237
 238    begin
 239
 240       case Deref (Ast).Sym_Type is
 241
 242          when Atom =>
 243
 244             declare
 245               Sym : Mal_String := Deref_Atom (Ast).Get_Atom;
 246             begin
 247                -- if keyword or nil (which may represent False)...
 248                if Sym(1) = ':' then
 249                   return Ast;
 250                else
 251                   return Envs.Get (Env, Sym);
 252                end if;
 253             exception
 254                when Envs.Not_Found =>
 255                   return New_Error_Mal_Type ("'" &  Sym & "' not found");
 256             end;
 257
 258          when List =>
 259
 260             return Map (Call_Eval'Unrestricted_Access, Deref_List (Ast).all);
 261
 262          when others => return Ast;
 263
 264       end case;
 265
 266    end Eval_Ast;
 267
 268
 269    function Do_Processing (Do_List : Types.List_Mal_Type; Env : Envs.Env_Handle)
 270    return Types.Mal_Handle is
 271       use Types;
 272       D : List_Mal_Type;
 273       Res : Mal_Handle := Smart_Pointers.Null_Smart_Pointer;
 274    begin
 275       if Debug then
 276          Ada.Text_IO.Put_Line ("Do-ing " & To_String (Do_List));
 277       end if;
 278       D := Do_List;
 279       while not Is_Null (D) loop
 280          Res := Eval_Ast (Car (D), Env);
 281          D := Deref_List (Cdr(D)).all;
 282       end loop;
 283       return Res;
 284    end Do_Processing;
 285
 286
 287    function List_Processing (L : Types.Mal_Handle; Env : Envs.Env_Handle)
 288    return Types.Mal_Handle is
 289       use Types;
 290       pragma Assert (Deref (L).Sym_Type = List,
 291                      "List_Processing: expected a list");
 292       Evaled_List : List_Mal_Type;
 293       Func, Args : Mal_Handle;
 294    begin
 295       Evaled_List := Deref_List (Eval_Ast (L, Env)).all;
 296       Func := Car (Evaled_List);
 297       Args := Cdr (Evaled_List);
 298       return Apply (Func, Args);
 299    end List_Processing;
 300
 301
 302    function Eval_As_List (MH : Types.Mal_Handle) return List_Mal_Type is
 303    begin
 304       case Deref (MH).Sym_Type is
 305          when List =>  return Deref_List (MH).all;
 306          when Atom =>
 307             if Deref_Atom (MH).Get_Atom = "nil" then
 308                return Null_List (List_List);
 309             end if;
 310          when others => null;
 311       end case;
 312       raise Evaluation_Error with "Expecting a List";
 313       return Null_List (List_List);
 314    end Eval_As_List;
 315
 316
 317    function Eval_List (L : Types.Mal_Handle; Env : Envs.Env_Handle)
 318    return Types.Mal_Handle is
 319
 320       use Types;
 321       pragma Assert (Deref (L).Sym_Type = List,
 322                      "Eval_List: expected a List");
 323       LMT, Rest_List : List_Mal_Type;
 324       First_Elem, Rest_Handle : Mal_Handle;
 325
 326    begin
 327
 328       LMT := Deref_List (L).all;
 329
 330       First_Elem := Car (LMT);
 331
 332       Rest_List := Deref_List (Cdr (LMT)).all;
 333
 334       case Deref (First_Elem).Sym_Type is
 335
 336          when Atom =>
 337
 338             declare
 339                Atom_P : Atom_Ptr;
 340             begin
 341                Atom_P := Deref_Atom (First_Elem);
 342                if Atom_P.Get_Atom = "def!" then
 343                   return Def_Fn (Rest_List, Env);
 344                elsif Atom_P.Get_Atom = "let*" then
 345                   return Let_Processing (Rest_List, Env);
 346                elsif Atom_P.Get_Atom = "do" then
 347                   return Do_Processing (Rest_List, Env);
 348                elsif Atom_P.Get_Atom = "if" then
 349                   return If_Processing (Rest_List, Env);
 350                elsif Atom_P.Get_Atom = "list?" then
 351                   declare
 352                      First_Param, Evaled_List : Mal_Handle;
 353                   begin
 354                      First_Param := Car (Rest_List);
 355                      Evaled_List := Eval (First_Param, Env);
 356                      return New_Bool_Mal_Type
 357                        (Deref (Evaled_List).Sym_Type = List and then
 358                         Deref_List (Evaled_List).Get_List_Type = List_List);
 359                   end;
 360                elsif Atom_P.Get_Atom = "empty?" then
 361                   declare
 362                      First_Param, Evaled_List : Mal_Handle;
 363                      List : List_Mal_Type;
 364                   begin
 365                      First_Param := Car (Rest_List);
 366                      Evaled_List := Eval (First_Param, Env);
 367                      List := Deref_List (Evaled_List).all;
 368                      return New_Bool_Mal_Type (Is_Null (List));
 369                   end;
 370                elsif Atom_P.Get_Atom = "count" then
 371                   declare
 372                      First_Param, Evaled_List : Mal_Handle;
 373                      List : List_Mal_Type;
 374                   begin
 375                      First_Param := Car (Rest_List);
 376                      Evaled_List := Eval (First_Param, Env);
 377                      List := Eval_As_List (Evaled_List);
 378                      return New_Int_Mal_Type (Length (List));
 379                   end;
 380                else -- not a special form
 381                   return List_Processing (L, Env);
 382                end if;
 383             end;
 384
 385          when Lambda =>
 386
 387             return Fn_Processing
 388                      (Deref_Lambda (First_Elem),
 389                       Cdr (LMT),
 390                       Env);
 391
 392          when Error => return First_Elem;
 393
 394          when others => return List_Processing (L, Env);
 395
 396       end case;
 397
 398    end Eval_List;
 399
 400
 401    function Eval (Param : Types.Mal_Handle; Env : Envs.Env_Handle)
 402    return Types.Mal_Handle is
 403       use Types;
 404       First_Elem : Mal_Handle;
 405    begin
 406
 407       if Debug then
 408          Ada.Text_IO.Put_Line ("Evaling " & Deref (Param).To_String);
 409       end if;
 410
 411       if Deref (Param).Sym_Type = List and then
 412          Deref_List (Param).all.Get_List_Type = List_List then
 413
 414          return Eval_List (Param, Env);
 415
 416       else
 417
 418          return Eval_Ast (Param, Env);
 419
 420       end if;
 421
 422    end Eval;
 423
 424
 425 end Evaluation;