impls/ada/core.adb

   1 with Ada.Calendar;
   2 with Ada.Characters.Latin_1;
   3 with Ada.Strings.Unbounded;
   4 with Ada.Text_IO;
   5 with Eval_Callback;
   6 with Reader;
   7 with Smart_Pointers;
   8 with Types;
   9 with Types.Hash_Map;
  10 with Types.Vector;
  11
  12 package body Core is
  13
  14    use Types;
  15
  16    -- primitive functions on Smart_Pointer,
  17    function "+" is new Arith_Op ("+", "+");
  18    function "-" is new Arith_Op ("-", "-");
  19    function "*" is new Arith_Op ("*", "*");
  20    function "/" is new Arith_Op ("/", "/");
  21
  22    function "<" is new Rel_Op ("<", "<");
  23    function "<=" is new Rel_Op ("<=", "<=");
  24    function ">" is new Rel_Op (">", ">");
  25    function ">=" is new Rel_Op (">=", ">=");
  26
  27
  28    function Eval_As_Boolean (MH : Types.Mal_Handle) return Boolean is
  29       use Types;
  30       Res : Boolean;
  31    begin
  32       case Deref (MH).Sym_Type is
  33          when Bool =>
  34             Res := Deref_Bool (MH).Get_Bool;
  35          when Nil =>
  36             Res := False;
  37 --         when List =>
  38 --            declare
  39 --               L : List_Mal_Type;
  40 --            begin
  41 --               L := Deref_List (MH).all;
  42 --               Res := not Is_Null (L);
  43 --            end;
  44          when others => -- Everything else
  45             Res := True;
  46       end case;
  47       return Res;
  48    end Eval_As_Boolean;
  49
  50
  51    function Throw (Rest_Handle : Mal_Handle)
  52    return Types.Mal_Handle is
  53       First_Param : Mal_Handle;
  54       Rest_List : Types.List_Mal_Type;
  55    begin
  56       Rest_List := Deref_List (Rest_Handle).all;
  57       First_Param := Car (Rest_List);
  58       Types.Mal_Exception_Value := First_Param;
  59       raise Mal_Exception;
  60       return First_Param;  -- Keep the compiler happy.
  61    end Throw;
  62
  63
  64    function Is_True (Rest_Handle : Mal_Handle)
  65    return Types.Mal_Handle is
  66       First_Param, Evaled_List : Mal_Handle;
  67       Rest_List : Types.List_Mal_Type;
  68    begin
  69       Rest_List := Deref_List (Rest_Handle).all;
  70       First_Param := Car (Rest_List);
  71       return New_Bool_Mal_Type
  72         (Deref (First_Param).Sym_Type = Bool and then
  73          Deref_Bool (First_Param).Get_Bool);
  74    end Is_True;
  75
  76
  77    function Is_False (Rest_Handle : Mal_Handle)
  78    return Types.Mal_Handle is
  79       First_Param, Evaled_List : Mal_Handle;
  80       Rest_List : Types.List_Mal_Type;
  81    begin
  82       Rest_List := Deref_List (Rest_Handle).all;
  83       First_Param := Car (Rest_List);
  84       return New_Bool_Mal_Type
  85         (Deref (First_Param).Sym_Type = Bool and then
  86          not Deref_Bool (First_Param).Get_Bool);
  87    end Is_False;
  88
  89
  90    function Is_Nil (Rest_Handle : Mal_Handle)
  91    return Types.Mal_Handle is
  92       First_Param, Evaled_List : Mal_Handle;
  93       Rest_List : Types.List_Mal_Type;
  94    begin
  95       Rest_List := Deref_List (Rest_Handle).all;
  96       First_Param := Car (Rest_List);
  97       return New_Bool_Mal_Type
  98         (Deref (First_Param).Sym_Type = Nil);
  99    end Is_Nil;
 100
 101
 102    function Meta (Rest_Handle : Mal_Handle)
 103    return Types.Mal_Handle is
 104       First_Param : Mal_Handle;
 105       Rest_List : Types.List_Mal_Type;
 106    begin
 107       Rest_List := Deref_List (Rest_Handle).all;
 108       First_Param := Car (Rest_List);
 109       return Deref (First_Param).Get_Meta;
 110    end Meta;
 111
 112
 113    function With_Meta (Rest_Handle : Mal_Handle)
 114    return Types.Mal_Handle is
 115       First_Param, Meta_Param, Res : Mal_Handle;
 116       Rest_List : Types.List_Mal_Type;
 117    begin
 118       Rest_List := Deref_List (Rest_Handle).all;
 119       First_Param := Car (Rest_List);
 120       Rest_List := Deref_List (Cdr (Rest_List)).all;
 121       Meta_Param := Car (Rest_List);
 122       Res := Copy (First_Param);
 123       Deref (Res).Set_Meta (Meta_Param);
 124       return Res;
 125    end With_Meta;
 126
 127
 128    function New_Atom (Rest_Handle : Mal_Handle)
 129    return Types.Mal_Handle is
 130       First_Param : Mal_Handle;
 131       Rest_List : Types.List_Mal_Type;
 132    begin
 133       Rest_List := Deref_List (Rest_Handle).all;
 134       First_Param := Car (Rest_List);
 135       return New_Atom_Mal_Type (First_Param);
 136    end New_Atom;
 137
 138    function Is_Atom (Rest_Handle : Mal_Handle)
 139    return Types.Mal_Handle is
 140       First_Param, Evaled_List : Mal_Handle;
 141       Rest_List : Types.List_Mal_Type;
 142    begin
 143       Rest_List := Deref_List (Rest_Handle).all;
 144       First_Param := Car (Rest_List);
 145       return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Atom);
 146    end Is_Atom;
 147
 148
 149    function Deref_Atm (Rest_Handle : Mal_Handle)
 150    return Types.Mal_Handle is
 151       First_Param : Mal_Handle;
 152       Rest_List : Types.List_Mal_Type;
 153    begin
 154       Rest_List := Deref_List (Rest_Handle).all;
 155       First_Param := Car (Rest_List);
 156       return Deref_Atom (First_Param).Get_Atom;
 157    end Deref_Atm;
 158
 159
 160    function Reset (Rest_Handle : Mal_Handle)
 161    return Types.Mal_Handle is
 162       First_Param, Atom_Param, New_Val : Mal_Handle;
 163       Rest_List : Types.List_Mal_Type;
 164    begin
 165       Rest_List := Deref_List (Rest_Handle).all;
 166       Atom_Param := Car (Rest_List);
 167       Rest_List := Deref_List (Cdr (Rest_List)).all;
 168       New_Val := Car (Rest_List);
 169       Deref_Atom (Atom_Param).Set_Atom (New_Val);
 170       return New_Val;
 171    end Reset;
 172
 173
 174    function Swap (Rest_Handle : Mal_Handle)
 175    return Types.Mal_Handle is
 176       First_Param, Atom_Param, Atom_Val, New_Val : Mal_Handle;
 177       Rest_List : Types.List_Mal_Type;
 178       Rest_List_Class : Types.List_Class_Ptr;
 179       Func_Param, Param_List : Mal_Handle;
 180    begin
 181       Rest_List := Deref_List (Rest_Handle).all;
 182       Atom_Param := Car (Rest_List);
 183       Rest_List := Deref_List (Cdr (Rest_List)).all;
 184       Func_Param := Car (Rest_List);
 185       Param_List := Cdr (Rest_List);
 186
 187       Rest_List_Class := Deref_List_Class (Param_List);
 188       Param_List := Rest_List_Class.Duplicate;
 189       Atom_Val := Deref_Atom (Atom_Param).Get_Atom;
 190       Param_List := Prepend (Atom_Val, Deref_List (Param_List).all);
 191       case Deref (Func_Param).Sym_Type is
 192          when Lambda =>
 193             New_Val := Deref_Lambda (Func_Param).Apply (Param_List);
 194          when Func =>
 195             New_Val := Deref_Func (Func_Param).Call_Func (Param_List);
 196          when others => raise Runtime_Exception with "Swap with bad func";
 197       end case;
 198       Deref_Atom (Atom_Param).Set_Atom (New_Val);
 199       return New_Val;
 200    end Swap;
 201
 202
 203    function Is_List (Rest_Handle : Mal_Handle)
 204    return Types.Mal_Handle is
 205       First_Param, Evaled_List : Mal_Handle;
 206       Rest_List : Types.List_Mal_Type;
 207    begin
 208       Rest_List := Deref_List (Rest_Handle).all;
 209       First_Param := Car (Rest_List);
 210       return New_Bool_Mal_Type
 211         (Deref (First_Param).Sym_Type = List and then
 212          Deref_List (First_Param).Get_List_Type = List_List);
 213    end Is_List;
 214
 215
 216    function Is_Vector (Rest_Handle : Mal_Handle)
 217    return Types.Mal_Handle is
 218       First_Param, Evaled_List : Mal_Handle;
 219       Rest_List : Types.List_Mal_Type;
 220    begin
 221       Rest_List := Deref_List (Rest_Handle).all;
 222       First_Param := Car (Rest_List);
 223       return New_Bool_Mal_Type
 224         (Deref (First_Param).Sym_Type = List and then
 225          Deref_List (First_Param).Get_List_Type = Vector_List);
 226    end Is_Vector;
 227
 228
 229    function Is_Map (Rest_Handle : Mal_Handle)
 230    return Types.Mal_Handle is
 231       First_Param, Evaled_List : Mal_Handle;
 232       Rest_List : Types.List_Mal_Type;
 233    begin
 234       Rest_List := Deref_List (Rest_Handle).all;
 235       First_Param := Car (Rest_List);
 236       return New_Bool_Mal_Type
 237         (Deref (First_Param).Sym_Type = List and then
 238          Deref_List (First_Param).Get_List_Type = Hashed_List);
 239    end Is_Map;
 240
 241
 242    function Is_Sequential (Rest_Handle : Mal_Handle)
 243    return Types.Mal_Handle is
 244       First_Param, Evaled_List : Mal_Handle;
 245       Rest_List : Types.List_Mal_Type;
 246    begin
 247       Rest_List := Deref_List (Rest_Handle).all;
 248       First_Param := Car (Rest_List);
 249       return New_Bool_Mal_Type
 250         (Deref (First_Param).Sym_Type = List and then
 251          Deref_List (First_Param).Get_List_Type /= Hashed_List);
 252    end Is_Sequential;
 253
 254
 255    function Is_Empty (Rest_Handle : Mal_Handle)
 256    return Types.Mal_Handle is
 257       First_Param, Evaled_List : Mal_Handle;
 258       List : List_Class_Ptr;
 259       Rest_List : Types.List_Mal_Type;
 260    begin
 261       Rest_List := Deref_List (Rest_Handle).all;
 262       First_Param := Car (Rest_List);
 263       List := Deref_List_Class (First_Param);
 264       return New_Bool_Mal_Type (Is_Null (List.all));
 265    end Is_Empty;
 266
 267
 268    function Eval_As_List (MH : Types.Mal_Handle) return List_Mal_Type is
 269    begin
 270       case Deref (MH).Sym_Type is
 271          when List   => return Deref_List (MH).all;
 272          when Nil    => return Null_List (List_List);
 273          when others => null;
 274       end case;
 275       raise Runtime_Exception with "Expecting a List";
 276       return Null_List (List_List);
 277    end Eval_As_List;
 278
 279
 280    function Count (Rest_Handle : Mal_Handle)
 281    return Types.Mal_Handle is
 282       First_Param, Evaled_List : Mal_Handle;
 283       L : List_Mal_Type;
 284       Rest_List : Types.List_Mal_Type;
 285       N : Natural;
 286    begin
 287       Rest_List := Deref_List (Rest_Handle).all;
 288       First_Param := Car (Rest_List);
 289       if Deref (First_Param).Sym_Type = List and then
 290          Deref_List (First_Param).Get_List_Type = Vector_List then
 291          N := Deref_List_Class (First_Param).Length;
 292       else
 293          L := Eval_As_List (First_Param);
 294          N := L.Length;
 295       end if;
 296       return New_Int_Mal_Type (N);
 297    end Count;
 298
 299
 300    function Cons (Rest_Handle : Mal_Handle)
 301    return Types.Mal_Handle is
 302       Rest_List : Types.List_Mal_Type;
 303       First_Param, List_Handle : Mal_Handle;
 304       List : List_Mal_Type;
 305       List_Class : List_Class_Ptr;
 306    begin
 307       Rest_List := Deref_List (Rest_Handle).all;
 308       First_Param := Car (Rest_List);
 309       List_Handle := Cdr (Rest_List);
 310       List := Deref_List (List_Handle).all;
 311       List_Handle := Car (List);
 312       List_Class := Deref_List_Class (List_Handle);
 313       return Prepend (First_Param, List_Class.all);
 314    end Cons;
 315
 316
 317    function Concat (Rest_Handle : Mal_Handle)
 318    return Types.Mal_Handle is
 319       Rest_List : Types.List_Mal_Type;
 320    begin
 321       Rest_List := Deref_List (Rest_Handle).all;
 322       return Types.Concat (Rest_List);
 323    end Concat;
 324
 325
 326    function First (Rest_Handle : Mal_Handle)
 327    return Types.Mal_Handle is
 328       Rest_List : Types.List_Mal_Type;
 329       First_List : Types.List_Class_Ptr;
 330       First_Param : Mal_Handle;
 331    begin
 332       Rest_List := Deref_List (Rest_Handle).all;
 333       First_Param := Car (Rest_List);
 334       if Deref (First_Param).Sym_Type = Nil then
 335          return New_Nil_Mal_Type;
 336       end if;
 337       First_List := Deref_List_Class (First_Param);
 338       if Is_Null (First_List.all) then
 339          return New_Nil_Mal_Type;
 340       else
 341          return Types.Car (First_List.all);
 342       end if;
 343    end First;
 344
 345
 346    function Rest (Rest_Handle : Mal_Handle)
 347    return Types.Mal_Handle is
 348       Rest_List : Types.List_Mal_Type;
 349       First_Param, Container : Mal_Handle;
 350    begin
 351       Rest_List := Deref_List (Rest_Handle).all;
 352       First_Param := Car (Rest_List);
 353       if Deref (First_Param).Sym_Type = Nil then
 354          return New_List_Mal_Type (List_List);
 355       end if;
 356       Container := Deref_List_Class (First_Param).Cdr;
 357       return Deref_List_Class (Container).Duplicate;
 358    end Rest;
 359
 360
 361    function Nth (Rest_Handle : Mal_Handle)
 362    return Types.Mal_Handle is
 363       -- Rest_List, First_List : Types.List_Mal_Type;
 364       Rest_List : Types.List_Mal_Type;
 365       First_List : Types.List_Class_Ptr;
 366       First_Param, List_Handle, Num_Handle : Mal_Handle;
 367       List : List_Mal_Type;
 368       Index : Types.Int_Mal_Type;
 369    begin
 370       Rest_List := Deref_List (Rest_Handle).all;
 371       First_Param := Car (Rest_List);
 372       First_List := Deref_List_Class (First_Param);
 373       List_Handle := Cdr (Rest_List);
 374       List := Deref_List (List_Handle).all;
 375       Num_Handle := Car (List);
 376       Index := Deref_Int (Num_Handle).all;
 377       return Types.Nth (First_List.all, Natural (Index.Get_Int_Val));
 378    end Nth;
 379
 380
 381    function Apply (Rest_Handle : Mal_Handle)
 382    return Types.Mal_Handle is
 383
 384       Results_Handle, First_Param : Mal_Handle;
 385       Rest_List : List_Mal_Type;
 386       Results_List : List_Ptr;
 387
 388    begin
 389
 390       -- The rest of the line.
 391       Rest_List := Deref_List (Rest_Handle).all;
 392       First_Param := Car (Rest_List);
 393       Rest_List := Deref_List (Cdr (Rest_List)).all;
 394
 395       Results_Handle := New_List_Mal_Type (List_List);
 396       Results_List := Deref_List (Results_Handle);
 397
 398       -- The last item is a list or a vector which gets flattened so that
 399       -- (apply f (A B) C (D E)) becomes (f (A B) C D E)
 400       while not Is_Null (Rest_List) loop
 401          declare
 402             Part_Handle : Mal_Handle;
 403          begin
 404             Part_Handle := Car (Rest_List);
 405             Rest_List := Deref_List (Cdr (Rest_List)).all;
 406
 407             -- Is Part_Handle the last item in the list?
 408             if Is_Null (Rest_List) then
 409                declare
 410                   The_List : List_Class_Ptr;
 411                   List_Item : Mal_Handle;
 412                   Next_List : Mal_Handle;
 413                begin
 414                   The_List := Deref_List_Class (Part_Handle);
 415                   while not Is_Null (The_List.all) loop
 416                      List_Item := Car (The_List.all);
 417                      Append (Results_List.all, List_Item);
 418                      Next_List := Cdr (The_List.all);
 419                      The_List := Deref_List_Class (Next_List);
 420                   end loop;
 421                end;
 422             else
 423                Append (Results_List.all, Part_Handle);
 424             end if;
 425          end;
 426       end loop;
 427
 428       -- The apply part...
 429       if Deref (First_Param).Sym_Type = Func then
 430          return Call_Func (Deref_Func (First_Param).all, Results_Handle);
 431       elsif Deref (First_Param).Sym_Type = Lambda then
 432          declare
 433
 434             L : Lambda_Mal_Type;
 435             E : Envs.Env_Handle;
 436             Param_Names : List_Mal_Type;
 437             Res : Mal_Handle;
 438
 439          begin
 440
 441             L := Deref_Lambda (First_Param).all;
 442             E := Envs.New_Env (L.Get_Env);
 443
 444             Param_Names := Deref_List (L.Get_Params).all;
 445
 446             if Envs.Bind (E, Param_Names, Results_List.all) then
 447
 448                return Eval_Callback.Eval.all (L.Get_Expr, E);
 449
 450             else
 451
 452                raise Runtime_Exception with "Bind failed in Apply";
 453
 454             end if;
 455
 456          end;
 457
 458       else  -- neither a Lambda or a Func
 459          raise Runtime_Exception with "Deref called on non-Func/Lambda";
 460       end if;
 461
 462    end Apply;
 463
 464
 465    function Map (Rest_Handle : Mal_Handle)
 466    return Types.Mal_Handle is
 467
 468       Rest_List, Results_List : List_Mal_Type;
 469       Func_Handle, List_Handle, Results_Handle : Mal_Handle;
 470
 471    begin
 472
 473       -- The rest of the line.
 474       Rest_List := Deref_List (Rest_Handle).all;
 475
 476       Func_Handle := Car (Rest_List);
 477       List_Handle := Nth (Rest_List, 1);
 478
 479       Results_Handle := New_List_Mal_Type (List_List);
 480       Results_List := Deref_List (Results_Handle).all;
 481
 482       while not Is_Null (Deref_List_Class (List_Handle).all) loop
 483
 484          declare
 485             Parts_Handle : Mal_Handle;
 486          begin
 487             Parts_Handle :=
 488               Make_New_List
 489                 ((1 => Func_Handle,
 490                   2 => Make_New_List
 491                          ((1 => Car (Deref_List_Class (List_Handle).all)))));
 492
 493             List_Handle := Cdr (Deref_List_Class (List_Handle).all);
 494
 495             Append
 496               (Results_List,
 497                Apply (Parts_Handle));
 498
 499          end;
 500
 501       end loop;
 502
 503       return New_List_Mal_Type (Results_List);
 504
 505    end Map;
 506
 507
 508    function Symbol (Rest_Handle : Mal_Handle)
 509    return Types.Mal_Handle is
 510
 511       Sym_Handle : Mal_Handle;
 512       Rest_List : List_Mal_Type;
 513
 514    begin
 515
 516       -- The rest of the line.
 517       Rest_List := Deref_List (Rest_Handle).all;
 518
 519       Sym_Handle := Car (Rest_List);
 520
 521       return New_Symbol_Mal_Type (Deref_String (Sym_Handle).Get_String);
 522
 523    end Symbol;
 524
 525
 526    function Is_Symbol (Rest_Handle : Mal_Handle)
 527    return Types.Mal_Handle is
 528
 529       Sym_Handle : Mal_Handle;
 530       Rest_List : List_Mal_Type;
 531       Res : Boolean;
 532
 533    begin
 534       Rest_List := Deref_List (Rest_Handle).all;
 535       Sym_Handle := Car (Rest_List);
 536       if Deref (Sym_Handle).Sym_Type = Sym then
 537          Res := Deref_Sym (Sym_Handle).Get_Sym (1) /= ':';
 538       else
 539          Res := False;
 540       end if;
 541       return New_Bool_Mal_Type (Res);
 542    end Is_Symbol;
 543
 544
 545    function Is_String (Rest_Handle : Mal_Handle) return Types.Mal_Handle is
 546       First_Param : Mal_Handle;
 547    begin
 548       First_Param := Car (Deref_List (Rest_Handle).all);
 549       return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Str);
 550    end Is_String;
 551
 552
 553    function Keyword (Rest_Handle : Mal_Handle)
 554    return Types.Mal_Handle is
 555
 556       Sym_Handle : Mal_Handle;
 557       Rest_List : List_Mal_Type;
 558
 559    begin
 560
 561       -- The rest of the line.
 562       Rest_List := Deref_List (Rest_Handle).all;
 563
 564       Sym_Handle := Car (Rest_List);
 565
 566       return New_Symbol_Mal_Type (':' & Deref_String (Sym_Handle).Get_String);
 567
 568    end Keyword;
 569
 570
 571    function Is_Keyword (Rest_Handle : Mal_Handle)
 572    return Types.Mal_Handle is
 573
 574       Sym_Handle : Mal_Handle;
 575       Rest_List : List_Mal_Type;
 576       Res : Boolean;
 577
 578    begin
 579       Rest_List := Deref_List (Rest_Handle).all;
 580       Sym_Handle := Car (Rest_List);
 581       if Deref (Sym_Handle).Sym_Type = Sym then
 582          Res := Deref_Sym (Sym_Handle).Get_Sym (1) = ':';
 583       else
 584          Res := False;
 585       end if;
 586       return New_Bool_Mal_Type (Res);
 587    end Is_Keyword;
 588
 589
 590    function Is_Number (Rest_Handle : Mal_Handle) return Types.Mal_Handle is
 591       First_Param : Mal_Handle;
 592    begin
 593       First_Param := Car (Deref_List (Rest_Handle).all);
 594       return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Int);
 595    end Is_Number;
 596
 597
 598    function Is_Fn (Rest_Handle : Mal_Handle) return Types.Mal_Handle is
 599       First_Param : Mal_Handle;
 600       Res : Boolean;
 601    begin
 602       First_Param := Car (Deref_List (Rest_Handle).all);
 603       case Deref (First_Param).Sym_Type is
 604          when Func =>
 605             Res := True;
 606          when Lambda =>
 607             Res := not Deref_Lambda (First_Param).Get_Is_Macro;
 608          when others =>
 609             Res := False;
 610       end case;
 611       return New_Bool_Mal_Type (Res);
 612    end Is_Fn;
 613
 614
 615    function Is_Macro (Rest_Handle : Mal_Handle) return Types.Mal_Handle is
 616       First_Param : Mal_Handle;
 617    begin
 618       First_Param := Car (Deref_List (Rest_Handle).all);
 619       return New_Bool_Mal_Type (Deref (First_Param).Sym_Type = Lambda and then Deref_Lambda (First_Param).Get_Is_Macro);
 620    end Is_Macro;
 621
 622
 623    function New_List (Rest_Handle : Mal_Handle)
 624    return Types.Mal_Handle is
 625       Rest_List : Types.List_Mal_Type;
 626    begin
 627       Rest_List := Deref_List (Rest_Handle).all;
 628       return New_List_Mal_Type (The_List => Rest_List);
 629    end New_List;
 630
 631
 632    function New_Vector (Rest_Handle : Mal_Handle)
 633    return Types.Mal_Handle is
 634       Rest_List : List_Mal_Type;
 635       Res : Mal_Handle;
 636       use Types.Vector;
 637    begin
 638       Res := New_Vector_Mal_Type;
 639       Rest_List := Deref_List (Rest_Handle).all;
 640       while not Is_Null (Rest_List) loop
 641          Deref_Vector (Res).Append (Car (Rest_List));
 642          Rest_List := Deref_List (Cdr (Rest_List)).all;
 643       end loop;
 644       return Res;
 645    end New_Vector;
 646
 647
 648    function Vec (Rest_Handle : Mal_Handle)
 649    return Types.Mal_Handle is
 650       First_Param : Mal_Handle;
 651    begin
 652       First_Param := Car (Deref_List (Rest_Handle).all);
 653       if Deref (First_Param).Sym_Type /= List then
 654          raise Runtime_Exception with "Expecting a sequence";
 655       end if;
 656       case Deref_List_Class (First_Param).Get_List_Type is
 657       when Hashed_List =>
 658          raise Runtime_Exception with "Expecting a sequence";
 659       when Vector_List =>
 660          return First_Param;
 661       when List_List =>
 662          return New_Vector (First_Param);
 663       end case;
 664    end Vec;
 665
 666
 667    function New_Map (Rest_Handle : Mal_Handle)
 668    return Types.Mal_Handle is
 669       Rest_List : List_Mal_Type;
 670       Res : Mal_Handle;
 671    begin
 672       Res := Hash_Map.New_Hash_Map_Mal_Type;
 673       Rest_List := Deref_List (Rest_Handle).all;
 674       while not Is_Null (Rest_List) loop
 675          Hash_Map.Deref_Hash (Res).Append (Car (Rest_List));
 676          Rest_List := Deref_List (Cdr (Rest_List)).all;
 677       end loop;
 678       return Res;
 679    end New_Map;
 680
 681
 682    function Assoc (Rest_Handle : Mal_Handle)
 683    return Types.Mal_Handle is
 684       Rest_List : Mal_Handle;
 685       Map : Hash_Map.Hash_Map_Mal_Type;
 686    begin
 687       Rest_List := Rest_Handle;
 688       Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all;
 689       Rest_List := Cdr (Deref_List (Rest_List).all);
 690       return Hash_Map.Assoc (Map, Rest_List);
 691    end Assoc;
 692
 693
 694    function Dis_Assoc (Rest_Handle : Mal_Handle)
 695    return Types.Mal_Handle is
 696       Rest_List : Mal_Handle;
 697       Map : Hash_Map.Hash_Map_Mal_Type;
 698    begin
 699       Rest_List := Rest_Handle;
 700       Map := Hash_Map.Deref_Hash (Car (Deref_List (Rest_List).all)).all;
 701       Rest_List := Cdr (Deref_List (Rest_List).all);
 702       return Hash_Map.Dis_Assoc (Map, Rest_List);
 703    end Dis_Assoc;
 704
 705
 706    function Get_Key (Rest_Handle : Mal_Handle)
 707    return Types.Mal_Handle is
 708       Rest_List : List_Mal_Type;
 709       Map : Hash_Map.Hash_Map_Mal_Type;
 710       Map_Param, Key : Mal_Handle;
 711       The_Sym : Sym_Types;
 712    begin
 713
 714       Rest_List := Deref_List (Rest_Handle).all;
 715       Map_Param := Car (Rest_List);
 716       The_Sym := Deref (Map_Param).Sym_Type;
 717       if The_Sym = Sym or The_Sym = Nil then
 718          -- Either its nil or its some other atom
 719          -- which makes no sense!
 720          return New_Nil_Mal_Type;
 721       end if;
 722
 723       -- Assume a map from here on in.
 724       Map := Hash_Map.Deref_Hash (Car (Rest_List)).all;
 725       Rest_List := Deref_List (Cdr (Rest_List)).all;
 726       Key := Car (Rest_List);
 727
 728       return Map.Get (Key);
 729
 730    end Get_Key;
 731
 732
 733    function Contains_Key (Rest_Handle : Mal_Handle)
 734    return Types.Mal_Handle is
 735       Rest_List : List_Mal_Type;
 736       Map : Hash_Map.Hash_Map_Mal_Type;
 737       Key : Mal_Handle;
 738    begin
 739       Rest_List := Deref_List (Rest_Handle).all;
 740       Map := Hash_Map.Deref_Hash (Car (Rest_List)).all;
 741       Rest_List := Deref_List (Cdr (Rest_List)).all;
 742       Key := Car (Rest_List);
 743       return New_Bool_Mal_Type (Hash_Map.Contains (Map, Key));
 744    end Contains_Key;
 745
 746
 747    function All_Keys (Rest_Handle : Mal_Handle)
 748    return Types.Mal_Handle is
 749       Rest_List : List_Mal_Type;
 750       Map : Hash_Map.Hash_Map_Mal_Type;
 751    begin
 752       Rest_List := Deref_List (Rest_Handle).all;
 753       Map := Hash_Map.Deref_Hash (Car (Rest_List)).all;
 754       return Hash_Map.All_Keys (Map);
 755    end All_Keys;
 756
 757
 758    function All_Values (Rest_Handle : Mal_Handle)
 759    return Types.Mal_Handle is
 760       Rest_List : List_Mal_Type;
 761       Map : Hash_Map.Hash_Map_Mal_Type;
 762    begin
 763       Rest_List := Deref_List (Rest_Handle).all;
 764       Map := Hash_Map.Deref_Hash (Car (Rest_List)).all;
 765       return Hash_Map.All_Values (Map);
 766    end All_Values;
 767
 768
 769    -- Take a list with two parameters and produce a single result
 770    -- using the Op access-to-function parameter.
 771    function Reduce2
 772      (Op : Binary_Func_Access; LH : Mal_Handle)
 773    return Mal_Handle is
 774       Left, Right : Mal_Handle;
 775       L, Rest_List : List_Mal_Type;
 776    begin
 777       L := Deref_List (LH).all;
 778       Left := Car (L);
 779       Rest_List := Deref_List (Cdr (L)).all;
 780       Right := Car (Rest_List);
 781       return Op (Left, Right);
 782    end Reduce2;
 783
 784
 785    function Plus (Rest_Handle : Mal_Handle)
 786    return Types.Mal_Handle is
 787    begin
 788        return Reduce2 ("+"'Access, Rest_Handle);
 789    end Plus;
 790
 791
 792    function Minus (Rest_Handle : Mal_Handle)
 793    return Types.Mal_Handle is
 794    begin
 795        return Reduce2 ("-"'Access, Rest_Handle);
 796    end Minus;
 797
 798
 799    function Mult (Rest_Handle : Mal_Handle)
 800    return Types.Mal_Handle is
 801    begin
 802        return Reduce2 ("*"'Access, Rest_Handle);
 803    end Mult;
 804
 805
 806    function Divide (Rest_Handle : Mal_Handle)
 807    return Types.Mal_Handle is
 808    begin
 809        return Reduce2 ("/"'Access, Rest_Handle);
 810    end Divide;
 811
 812
 813    function LT (Rest_Handle : Mal_Handle)
 814    return Types.Mal_Handle is
 815    begin
 816        return Reduce2 ("<"'Access, Rest_Handle);
 817    end LT;
 818
 819
 820    function LTE (Rest_Handle : Mal_Handle)
 821    return Types.Mal_Handle is
 822    begin
 823        return Reduce2 ("<="'Access, Rest_Handle);
 824    end LTE;
 825
 826
 827    function GT (Rest_Handle : Mal_Handle)
 828    return Types.Mal_Handle is
 829    begin
 830        return Reduce2 (">"'Access, Rest_Handle);
 831    end GT;
 832
 833
 834    function GTE (Rest_Handle : Mal_Handle)
 835    return Types.Mal_Handle is
 836    begin
 837        return Reduce2 (">="'Access, Rest_Handle);
 838    end GTE;
 839
 840
 841    function EQ (Rest_Handle : Mal_Handle)
 842    return Types.Mal_Handle is
 843    begin
 844        return Reduce2 (Types."="'Access, Rest_Handle);
 845    end EQ;
 846
 847
 848    function Pr_Str (Rest_Handle : Mal_Handle)
 849    return Types.Mal_Handle is
 850    begin
 851       return New_String_Mal_Type (Deref_List (Rest_Handle).Pr_Str);
 852    end Pr_Str;
 853
 854
 855    function Prn (Rest_Handle : Mal_Handle)
 856    return Types.Mal_Handle is
 857    begin
 858       Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str);
 859       return New_Nil_Mal_Type;
 860    end Prn;
 861
 862
 863    function Println (Rest_Handle : Mal_Handle)
 864    return Types.Mal_Handle is
 865    begin
 866       Ada.Text_IO.Put_Line (Deref_List (Rest_Handle).Pr_Str (False));
 867       return New_Nil_Mal_Type;
 868    end Println;
 869
 870
 871    function Str (Rest_Handle : Mal_Handle)
 872    return Types.Mal_Handle is
 873    begin
 874       return New_String_Mal_Type (Deref_List (Rest_Handle).Cat_Str (False));
 875    end Str;
 876
 877
 878    function Read_String (Rest_Handle : Mal_Handle)
 879    return Types.Mal_Handle is
 880       Rest_List : Types.List_Mal_Type;
 881       First_Param : Mal_Handle;
 882    begin
 883       Rest_List := Deref_List (Rest_Handle).all;
 884       First_Param := Car (Rest_List);
 885       return Reader.Read_Str (Deref_String (First_Param).Get_String);
 886    end Read_String;
 887
 888
 889    function Read_Line (Rest_Handle : Mal_Handle)
 890    return Types.Mal_Handle is
 891       Rest_List : Types.List_Mal_Type;
 892       First_Param : Mal_Handle;
 893    begin
 894       Rest_List := Deref_List (Rest_Handle).all;
 895       First_Param := Car (Rest_List);
 896       -- Output the prompt.
 897       Ada.Text_IO.Put (Deref_String (First_Param).Get_String);
 898       -- Get the text.
 899       return New_String_Mal_Type (Ada.Text_IO.Get_Line);
 900    end Read_Line;
 901
 902
 903    function Slurp (Rest_Handle : Mal_Handle)
 904    return Types.Mal_Handle is
 905       Rest_List : Types.List_Mal_Type;
 906       First_Param : Mal_Handle;
 907    begin
 908       Rest_List := Deref_List (Rest_Handle).all;
 909       First_Param := Car (Rest_List);
 910       declare
 911          Unquoted_Str : String := Deref_String (First_Param).Get_String;
 912          use Ada.Text_IO;
 913          Fn : Ada.Text_IO.File_Type;
 914          File_Str : Ada.Strings.Unbounded.Unbounded_String :=
 915            Ada.Strings.Unbounded.Null_Unbounded_String;
 916          I : Natural := 0;
 917       begin
 918          Ada.Text_IO.Open (Fn, In_File, Unquoted_Str);
 919          while not End_Of_File (Fn) loop
 920             declare
 921                Line_Str : constant String := Get_Line (Fn);
 922             begin
 923                if Line_Str'Length > 0 then
 924                   Ada.Strings.Unbounded.Append (File_Str, Line_Str);
 925                   Ada.Strings.Unbounded.Append (File_Str, Ada.Characters.Latin_1.LF);
 926                end if;
 927             end;
 928          end loop;
 929          Ada.Text_IO.Close (Fn);
 930          return New_String_Mal_Type (Ada.Strings.Unbounded.To_String (File_Str));
 931       end;
 932    end Slurp;
 933
 934
 935    function Conj (Rest_Handle : Mal_Handle)
 936    return Types.Mal_Handle is
 937       Rest_List : List_Mal_Type;
 938       First_Param, Res : Mal_Handle;
 939    begin
 940       Rest_List := Deref_List (Rest_Handle).all;
 941       First_Param := Car (Rest_List);
 942       Rest_List := Deref_List (Cdr (Rest_List)).all;
 943
 944       -- Is this a List or a Vector?
 945       case Deref_List (First_Param).Get_List_Type is
 946          when List_List =>
 947             Res := Copy (First_Param);
 948             while not Is_Null (Rest_List) loop
 949                Res := Prepend (To_List => Deref_List (Res).all, Op => Car (Rest_List));
 950                Rest_List := Deref_List (Cdr (Rest_List)).all;
 951             end loop;
 952             return Res;
 953          when Vector_List =>
 954             Res := Copy (First_Param);
 955             while not Is_Null (Rest_List) loop
 956                Vector.Append (Vector.Deref_Vector (Res).all, Car (Rest_List));
 957                Rest_List := Deref_List (Cdr (Rest_List)).all;
 958             end loop;
 959             return Res;
 960          when Hashed_List => raise Runtime_Exception with "Conj on Hashed_Map";
 961       end case;
 962    end Conj;
 963
 964
 965    function Seq (Rest_Handle : Mal_Handle)
 966    return Types.Mal_Handle is
 967       First_Param, Res : Mal_Handle;
 968    begin
 969       First_Param := Car (Deref_List (Rest_Handle).all);
 970       case Deref (First_Param).Sym_Type is
 971          when Nil => return First_Param;
 972          when List =>
 973             case Deref_List (First_Param).Get_List_Type is
 974                when List_List =>
 975                   if Is_Null (Deref_List (First_Param).all) then
 976                      return New_Nil_Mal_Type;
 977                   else
 978                      return First_Param;
 979                   end if;
 980                when Vector_List =>
 981                   if Vector.Is_Null (Vector.Deref_Vector (First_Param).all) then
 982                      return New_Nil_Mal_Type;
 983                   else
 984                      return Vector.Duplicate (Vector.Deref_Vector (First_Param).all);
 985                   end if;
 986                when others => raise Runtime_Exception;
 987             end case;
 988          when Str =>
 989             declare
 990                Param_Str : String := Deref_String (First_Param).Get_String;
 991                String1 : String (1 .. 1);
 992                L_Ptr : List_Ptr;
 993             begin
 994                if Param_Str'Length = 0 then
 995                   return New_Nil_Mal_Type; -- ""
 996                else
 997                   Res := New_List_Mal_Type (List_List);
 998                   L_Ptr := Deref_List (Res);
 999                   for I in Param_Str'First .. Param_Str'Last loop
1000                      String1 (1) := Param_Str (I);
1001                      Append (L_Ptr.all, New_String_Mal_Type (String1));
1002                   end loop;
1003                   return Res;
1004                end if;
1005             end;
1006          when others => raise Runtime_Exception;
1007       end case;
1008    end Seq;
1009
1010
1011    Start_Time : Ada.Calendar.Time := Ada.Calendar.Clock;
1012
1013    function Time_Ms (Rest_Handle : Mal_Handle)
1014    return Types.Mal_Handle is
1015       D : Duration;
1016       use Ada.Calendar;
1017    begin
1018       D := Clock - Start_Time;  -- seconds
1019       D := D * 1000.0;  -- milli-seconds
1020       return New_Int_Mal_Type (Integer (D));  -- ms rounded to the nearest one
1021    end Time_Ms;
1022
1023
1024    procedure Init (Repl_Env : Envs.Env_Handle) is
1025    begin
1026
1027       Envs.Set (Repl_Env, "*host-language*", Types.New_String_Mal_Type ("Ada"));
1028
1029       Envs.Set (Repl_Env,
1030            "true?",
1031            New_Func_Mal_Type ("true?", Is_True'access));
1032
1033       Envs.Set (Repl_Env,
1034            "false?",
1035            New_Func_Mal_Type ("false?", Is_False'access));
1036
1037       Envs.Set (Repl_Env,
1038            "meta",
1039            New_Func_Mal_Type ("meta", Meta'access));
1040
1041       Envs.Set (Repl_Env,
1042            "with-meta",
1043            New_Func_Mal_Type ("with-meta", With_Meta'access));
1044
1045       Envs.Set (Repl_Env,
1046            "nil?",
1047            New_Func_Mal_Type ("nil?", Is_Nil'access));
1048
1049       Envs.Set (Repl_Env,
1050            "throw",
1051            New_Func_Mal_Type ("throw", Throw'access));
1052
1053       Envs.Set (Repl_Env,
1054            "atom",
1055            New_Func_Mal_Type ("atom", New_Atom'access));
1056
1057       Envs.Set (Repl_Env,
1058            "atom?",
1059            New_Func_Mal_Type ("atom?", Is_Atom'access));
1060
1061       Envs.Set (Repl_Env,
1062            "deref",
1063            New_Func_Mal_Type ("deref", Deref_Atm'access));
1064
1065       Envs.Set (Repl_Env,
1066            "reset!",
1067            New_Func_Mal_Type ("reset!", Reset'access));
1068
1069       Envs.Set (Repl_Env,
1070            "swap!",
1071            New_Func_Mal_Type ("swap!", Swap'access));
1072
1073       Envs.Set (Repl_Env,
1074            "list",
1075            New_Func_Mal_Type ("list", New_List'access));
1076
1077       Envs.Set (Repl_Env,
1078            "list?",
1079            New_Func_Mal_Type ("list?", Is_List'access));
1080
1081       Envs.Set (Repl_Env,
1082            "vec",
1083            New_Func_Mal_Type ("vec", Vec'access));
1084
1085       Envs.Set (Repl_Env,
1086            "vector",
1087            New_Func_Mal_Type ("vector", New_Vector'access));
1088
1089       Envs.Set (Repl_Env,
1090            "vector?",
1091            New_Func_Mal_Type ("vector?", Is_Vector'access));
1092
1093       Envs.Set (Repl_Env,
1094            "hash-map",
1095            New_Func_Mal_Type ("hash-map", New_Map'access));
1096
1097       Envs.Set (Repl_Env,
1098            "assoc",
1099            New_Func_Mal_Type ("assoc", Assoc'access));
1100
1101       Envs.Set (Repl_Env,
1102            "dissoc",
1103            New_Func_Mal_Type ("dissoc", Dis_Assoc'access));
1104
1105       Envs.Set (Repl_Env,
1106            "get",
1107            New_Func_Mal_Type ("get", Get_Key'access));
1108
1109       Envs.Set (Repl_Env,
1110            "keys",
1111            New_Func_Mal_Type ("keys", All_Keys'access));
1112
1113       Envs.Set (Repl_Env,
1114            "vals",
1115            New_Func_Mal_Type ("vals", All_Values'access));
1116
1117       Envs.Set (Repl_Env,
1118            "map?",
1119            New_Func_Mal_Type ("map?", Is_Map'access));
1120
1121       Envs.Set (Repl_Env,
1122            "contains?",
1123            New_Func_Mal_Type ("contains?", Contains_Key'access));
1124
1125       Envs.Set (Repl_Env,
1126            "sequential?",
1127            New_Func_Mal_Type ("sequential?", Is_Sequential'access));
1128
1129       Envs.Set (Repl_Env,
1130            "empty?",
1131            New_Func_Mal_Type ("empty?", Is_Empty'access));
1132
1133       Envs.Set (Repl_Env,
1134            "count",
1135            New_Func_Mal_Type ("count", Count'access));
1136
1137       Envs.Set (Repl_Env,
1138            "cons",
1139            New_Func_Mal_Type ("cons", Cons'access));
1140
1141       Envs.Set (Repl_Env,
1142            "concat",
1143            New_Func_Mal_Type ("concat", Concat'access));
1144
1145       Envs.Set (Repl_Env,
1146            "first",
1147            New_Func_Mal_Type ("first", First'access));
1148
1149       Envs.Set (Repl_Env,
1150            "rest",
1151            New_Func_Mal_Type ("rest", Rest'access));
1152
1153       Envs.Set (Repl_Env,
1154            "nth",
1155            New_Func_Mal_Type ("nth", Nth'access));
1156
1157       Envs.Set (Repl_Env,
1158            "map",
1159            New_Func_Mal_Type ("map", Map'access));
1160
1161       Envs.Set (Repl_Env,
1162            "apply",
1163            New_Func_Mal_Type ("apply", Apply'access));
1164
1165       Envs.Set (Repl_Env,
1166            "symbol",
1167            New_Func_Mal_Type ("symbol", Symbol'access));
1168
1169       Envs.Set (Repl_Env,
1170            "symbol?",
1171            New_Func_Mal_Type ("symbol?", Is_Symbol'access));
1172
1173       Envs.Set (Repl_Env,
1174            "string?",
1175            New_Func_Mal_Type ("string?", Is_String'access));
1176
1177       Envs.Set (Repl_Env,
1178            "keyword",
1179            New_Func_Mal_Type ("keyword", Keyword'access));
1180
1181       Envs.Set (Repl_Env,
1182            "keyword?",
1183            New_Func_Mal_Type ("keyword?", Is_Keyword'access));
1184
1185       Envs.Set (Repl_Env,
1186            "number?",
1187            New_Func_Mal_Type ("number?", Is_Number'access));
1188
1189       Envs.Set (Repl_Env,
1190            "fn?",
1191            New_Func_Mal_Type ("fn?", Is_Fn'access));
1192
1193       Envs.Set (Repl_Env,
1194            "macro?",
1195            New_Func_Mal_Type ("macro?", Is_Macro'access));
1196
1197       Envs.Set (Repl_Env,
1198            "pr-str",
1199            New_Func_Mal_Type ("pr-str", Pr_Str'access));
1200
1201       Envs.Set (Repl_Env,
1202            "str",
1203            New_Func_Mal_Type ("str", Str'access));
1204
1205       Envs.Set (Repl_Env,
1206            "prn",
1207            New_Func_Mal_Type ("prn", Prn'access));
1208
1209       Envs.Set (Repl_Env,
1210            "println",
1211            New_Func_Mal_Type ("println", Println'access));
1212
1213       Envs.Set (Repl_Env,
1214            "read-string",
1215            New_Func_Mal_Type ("read-string", Read_String'access));
1216
1217       Envs.Set (Repl_Env,
1218            "readline",
1219            New_Func_Mal_Type ("readline", Read_Line'access));
1220
1221       Envs.Set (Repl_Env,
1222            "slurp",
1223            New_Func_Mal_Type ("slurp", Slurp'access));
1224
1225       Envs.Set (Repl_Env,
1226            "conj",
1227            New_Func_Mal_Type ("conj", Conj'access));
1228
1229       Envs.Set (Repl_Env,
1230            "seq",
1231            New_Func_Mal_Type ("seq", Seq'access));
1232
1233       Envs.Set (Repl_Env,
1234            "time-ms",
1235            New_Func_Mal_Type ("time-ms", Time_Ms'access));
1236
1237       Envs.Set (Repl_Env,
1238            "+",
1239            New_Func_Mal_Type ("+", Plus'access));
1240
1241       Envs.Set (Repl_Env,
1242            "-",
1243            New_Func_Mal_Type ("-", Minus'access));
1244
1245       Envs.Set (Repl_Env,
1246            "*",
1247            New_Func_Mal_Type ("*", Mult'access));
1248
1249       Envs.Set (Repl_Env,
1250            "/",
1251            New_Func_Mal_Type ("/", Divide'access));
1252
1253       Envs.Set (Repl_Env,
1254            "<",
1255            New_Func_Mal_Type ("<", LT'access));
1256
1257       Envs.Set (Repl_Env,
1258            "<=",
1259            New_Func_Mal_Type ("<=", LTE'access));
1260
1261       Envs.Set (Repl_Env,
1262            ">",
1263            New_Func_Mal_Type (">", GT'access));
1264
1265       Envs.Set (Repl_Env,
1266            ">=",
1267            New_Func_Mal_Type (">=", GTE'access));
1268
1269       Envs.Set (Repl_Env,
1270            "=",
1271            New_Func_Mal_Type ("=", EQ'access));
1272
1273    end Init;
1274
1275
1276 end Core;