objpascal/core.pas

   1 unit core;
   2
   3 {$H+} // Use AnsiString
   4
   5 interface
   6
   7 uses Classes,
   8      sysutils,
   9      fgl,
  10      mal_readline,
  11      mal_types,
  12      mal_func,
  13      mal_env,
  14      reader,
  15      printer;
  16
  17 type
  18     TCoreDict = specialize TFPGMap<string,TMalCallable>;
  19
  20 var
  21     EVAL : function (A: TMal; E: TEnv) : TMal;
  22     NS     : TCoreDict;
  23
  24 ////////////////////////////////////////////////////////////
  25
  26 implementation
  27
  28 // General functions
  29
  30 function equal_Q(Args: TMalArray) : TMal;
  31 begin
  32     equal_Q := wrap_tf(_equal_Q(Args[0], Args[1]));
  33 end;
  34
  35 function throw(Args: TMalArray) : TMal;
  36 begin
  37     raise TMalException.Create(Args[0]);
  38     throw := TMalNil.Create; // Not reached
  39 end;
  40
  41 // Scalar functions
  42
  43 function nil_Q(Args: TMalArray) : TMal;
  44 begin
  45     nil_Q := wrap_tf(Args[0] is TMalNil);
  46 end;
  47 function true_Q(Args: TMalArray) : TMal;
  48 begin
  49     true_Q := wrap_tf(Args[0] is TMalTrue);
  50 end;
  51 function false_Q(Args: TMalArray) : TMal;
  52 begin
  53     false_Q := wrap_tf(Args[0] is TMalFalse);
  54 end;
  55 function string_Q(Args: TMalArray) : TMal;
  56 begin
  57     string_Q := wrap_tf(_string_Q(Args[0]));
  58 end;
  59 function symbol(Args: TMalArray) : TMal;
  60 begin
  61     if Args[0] is TMalSymbol then
  62         symbol := Args[0]
  63     else if Args[0] is TMalString then
  64         symbol := TMalSymbol.Create((Args[0] as TMalString).Val)
  65     else
  66         raise Exception.Create('Invalid symbol call');
  67 end;
  68 function symbol_Q(Args: TMalArray) : TMal;
  69 begin
  70     symbol_Q := wrap_tf(Args[0] is TMalSymbol);
  71 end;
  72 function keyword(Args: TMalArray) : TMal;
  73 begin
  74     if ((Args[0] is TMalString) and not _string_Q(Args[0])) then
  75         keyword := Args[0]
  76     else if Args[0] is TMalString then
  77         keyword := TMalString.Create(#127 + (Args[0] as TMalString).Val)
  78     else
  79         raise Exception.Create('Invalid keyword call');
  80 end;
  81 function keyword_Q(Args: TMalArray) : TMal;
  82 begin
  83     keyword_Q := wrap_tf((Args[0] is TMalString) and not _string_Q(Args[0]));
  84 end;
  85
  86 // String functions
  87
  88 function do_pr_str(Args: TMalArray) : TMal;
  89 begin
  90     do_pr_str := TMalString.Create(pr_str_array(Args, true, ' '));
  91 end;
  92 function str(Args: TMalArray) : TMal;
  93 begin
  94     str := TMalString.Create(pr_str_array(Args, false, ''));
  95 end;
  96 function prn(Args: TMalArray) : TMal;
  97 begin
  98     WriteLn(pr_str_array(Args, true, ' '));
  99     prn := TMalNil.Create;
 100 end;
 101 function println(Args: TMalArray) : TMal;
 102 begin
 103     WriteLn(pr_str_array(Args, false, ' '));
 104     println := TMalNil.Create;
 105 end;
 106
 107 function read_string(Args: TMalArray) : TMal;
 108 begin
 109     read_string := read_str((Args[0] as TMalString).Val);
 110 end;
 111 function do_readline(Args: TMalArray) : TMal;
 112 var
 113     Prompt : string;
 114     Line   : string;
 115 begin
 116     Prompt := (Args[0] as TMalString).Val;
 117     try
 118         Line := _readline(Prompt);
 119         do_readline := TMalString.Create(Line);
 120     except
 121         On E : MalEOF do do_readline := TMalNil.Create;
 122     end;
 123 end;
 124 function slurp(Args: TMalArray) : TMal;
 125 var
 126     StrL : TStringList;
 127 begin
 128     StrL := TStringList.Create;
 129     StrL.LoadFromFile((Args[0] as TMalString).Val);
 130     slurp := TMalString.Create(StrL.Text);
 131 end;
 132
 133 // Math functions
 134
 135 function lt(Args: TMalArray) : TMal;
 136 begin
 137     lt := wrap_tf((Args[0] as TMalInt).Val < (Args[1] as TMalInt).Val);
 138 end;
 139 function lte(Args: TMalArray) : TMal;
 140 begin
 141     lte := wrap_tf((Args[0] as TMalInt).Val <= (Args[1] as TMalInt).Val);
 142 end;
 143 function gt(Args: TMalArray) : TMal;
 144 begin
 145     gt := wrap_tf((Args[0] as TMalInt).Val > (Args[1] as TMalInt).Val);
 146 end;
 147 function gte(Args: TMalArray) : TMal;
 148 begin
 149     gte := wrap_tf((Args[0] as TMalInt).Val >= (Args[1] as TMalInt).Val);
 150 end;
 151
 152 function add(Args: TMalArray) : TMal;
 153 begin
 154     add := TMalInt.Create((Args[0] as TMalInt).Val +
 155                           (Args[1] as TMalInt).Val);
 156 end;
 157 function subtract(Args: TMalArray) : TMal;
 158 begin
 159     subtract := TMalInt.Create((Args[0] as TMalInt).Val -
 160                                (Args[1] as TMalInt).Val);
 161 end;
 162 function multiply(Args: TMalArray) : TMal;
 163 begin
 164     multiply := TMalInt.Create((Args[0] as TMalInt).Val *
 165                                (Args[1] as TMalInt).Val);
 166 end;
 167 function divide(Args: TMalArray) : TMal;
 168 begin
 169     divide := TMalInt.Create((Args[0] as TMalInt).Val div
 170                              (Args[1] as TMalInt).Val);
 171 end;
 172 function time_ms(Args: TMalArray) : TMal;
 173 begin
 174     time_ms := TMalInt.Create(Trunc(TimeStampToMSecs(DateTimeToTimeStamp(Now))));
 175 end;
 176
 177 // Collection functions
 178
 179 function list(Args: TMalArray) : TMal;
 180 begin
 181     list := TMalList.Create(Args);
 182 end;
 183 function list_Q(Args: TMalArray) : TMal;
 184 begin
 185     list_Q := wrap_tf(Args[0].ClassType = TMalList);
 186 end;
 187 function vector(Args: TMalArray) : TMal;
 188 begin
 189     vector := TMalVector.Create(Args);
 190 end;
 191 function vector_Q(Args: TMalArray) : TMal;
 192 begin
 193     vector_Q := wrap_tf(Args[0].ClassType = TMalVector);
 194 end;
 195 function hash_map(Args: TMalArray) : TMal;
 196 begin
 197     hash_map := TMalHashMap.Create(Args);
 198 end;
 199 function map_Q(Args: TMalArray) : TMal;
 200 begin
 201     map_Q := wrap_tf(Args[0].ClassType = TMalHashMap);
 202 end;
 203 function assoc(Args: TMalArray) : TMal;
 204 var
 205     OrigHM, NewHM : TMalHashMap;
 206 begin
 207     OrigHM := (Args[0] as TMalHashMap);
 208     NewHM := TMalHashMap.Clone(OrigHM);
 209     assoc := NewHM.assoc_BANG(copy(Args, 1, Length(Args)));
 210 end;
 211 function dissoc(Args: TMalArray) : TMal;
 212 var
 213     OrigHM, NewHM : TMalHashMap;
 214 begin
 215     OrigHM := (Args[0] as TMalHashMap);
 216     NewHM := TMalHashMap.Clone(OrigHM);
 217     dissoc := NewHM.dissoc_BANG(copy(Args, 1, Length(Args)));
 218 end;
 219 function get(Args: TMalArray) : TMal;
 220 var
 221     HM : TMalHashMap;
 222 begin
 223     if Args[0] is TMalNil then Exit(TMalNil.Create);
 224     HM := (Args[0] as TMalHashMap);
 225     if HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0 then
 226         get := HM.Val[(Args[1] as TMalString).Val]
 227     else
 228         get := TMalNil.Create;
 229 end;
 230 function contains_Q(Args: TMalArray) : TMal;
 231 var
 232     HM : TMalHashMap;
 233 begin
 234     if Args[0] is TMalNil then Exit(TMalFalse.Create);
 235     HM := (Args[0] as TMalHashMap);
 236     contains_Q := wrap_tf(HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0);
 237 end;
 238 function keys(Args: TMalArray) : TMal;
 239 var
 240     Dict : TMalDict;
 241     Arr  : TMalArray;
 242     I    : longint;
 243 begin
 244     Dict := (Args[0] as TMalHashMap).Val;
 245     SetLength(Arr, Dict.Count);
 246     for I := 0 to Dict.Count-1 do
 247         Arr[I] := TMalString.Create(Dict.Keys[I]);
 248     keys := TMalList.Create(Arr);
 249 end;
 250 function vals(Args: TMalArray) : TMal;
 251 var
 252     Dict : TMalDict;
 253     Arr  : TMalArray;
 254     I    : longint;
 255 begin
 256     Dict := (Args[0] as TMalHashMap).Val;
 257     SetLength(Arr, Dict.Count);
 258     for I := 0 to Dict.Count-1 do
 259         Arr[I] := Dict[Dict.Keys[I]];
 260     vals := TMalList.Create(Arr);
 261 end;
 262
 263
 264 // Sequence functions
 265
 266 function sequential_Q(Args: TMalArray) : TMal;
 267 begin
 268     sequential_Q := wrap_tf(_sequential_Q(Args[0]));
 269 end;
 270 function cons(Args: TMalArray) : TMal;
 271 var
 272     Res, Src : TMalArray;
 273     I        : longint;
 274 begin
 275     Src := (Args[1] as TMalList).Val;
 276     SetLength(Res, 1 + Length(Src));
 277     Res[0] := Args[0];
 278     for I := 1 to Length(Src) do
 279         Res[I] := Src[I-1];
 280     cons := TMalList.Create(Res);
 281 end;
 282 function do_concat(Args: TMalArray) : TMal;
 283 var
 284     Res  : TMalArray;
 285     I    : longint;
 286 begin
 287     SetLength(Res, 0);
 288     for I := 0 to Length(Args)-1 do
 289     begin
 290         Res := _concat(Res, (Args[I] as TMalList).Val);
 291     end;
 292     do_concat := TMalList.Create(Res);
 293 end;
 294 function nth(Args: TMalArray) : TMal;
 295 var
 296     Arr : TMalArray;
 297     Idx : longint;
 298 begin
 299     Arr := (Args[0] as TMalList).Val;
 300     Idx := (Args[1] as TMalInt).Val;
 301     if Idx >= Length(Arr) then
 302         raise Exception.Create('nth: index out of range')
 303     else
 304         nth := Arr[Idx];
 305 end;
 306 function first(Args: TMalArray) : TMal;
 307 var
 308     Arr : TMalArray;
 309 begin
 310     if Args[0] is TMalNil then Exit(TMalNil.Create);
 311     Arr := (Args[0] as TMalList).Val;
 312     if Length(Arr) = 0 then
 313         first := TMalNil.Create
 314     else
 315         first := (Args[0] as TMalList).Val[0];
 316 end;
 317 function rest(Args: TMalArray) : TMal;
 318 begin
 319     if Args[0] is TMalNil then Exit(_list());
 320     rest := (Args[0] as TMalList).Rest();
 321 end;
 322
 323 function empty_Q(Args: TMalArray) : TMal;
 324 begin
 325     if Args[0] is TMalNil then
 326         empty_Q := TMalTrue.Create
 327     else if Args[0] is TMalList then
 328         empty_Q := wrap_tf(Length((Args[0] as TMalList).Val) = 0)
 329     else raise Exception.Create('invalid empty? call');
 330 end;
 331 function count(Args: TMalArray) : TMal;
 332 begin
 333     if Args[0] is TMalNil then
 334         count := TMalInt.Create(0)
 335     else if Args[0] is TMalList then
 336         count := TMalInt.Create(Length((Args[0] as TMalList).Val))
 337     else raise Exception.Create('invalid count call');
 338 end;
 339
 340 function map(Args: TMalArray) : TMal;
 341 var
 342     Fn       : TMalFunc;
 343     FArgs    : TMalArray;
 344     Src, Res : TMalArray;
 345     I        : longint;
 346 begin
 347     Fn := (Args[0] as TMalFunc);
 348     Src := (Args[1] as TMalList).Val;
 349     SetLength(FArgs, 1);
 350     SetLength(Res, Length(Src));
 351     if Fn.Ast = nil then
 352         for I := 0 to Length(Src)-1 do
 353         begin
 354             FArgs[0] := Src[I];
 355             Res[I] := Fn.Val(FArgs);
 356         end
 357     else
 358         for I := 0 to Length(Src)-1 do
 359         begin
 360             FArgs[0] := Src[I];
 361             Res[I] := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
 362         end;
 363     map := TMalList.Create(Res);
 364 end;
 365 function apply(Args: TMalArray) : TMal;
 366 var
 367     Fn       : TMalFunc;
 368     LastArgs : TMalArray;
 369     FArgs    : TMalArray;
 370     I        : longint;
 371 begin
 372     Fn := (Args[0] as TMalFunc);
 373     LastArgs := (Args[Length(Args)-1] as TMalList).Val;
 374     SetLength(FArgs, Length(LastArgs) + Length(Args) - 2);
 375     for I := 0 to Length(Args)-3 do
 376         FArgs[I] := Args[I+1];
 377     for I := 0 to Length(LastArgs)-1 do
 378         FArgs[Length(Args)-2 + I] := LastArgs[I];
 379     if Fn.Ast = nil then
 380         apply := Fn.Val(FArgs)
 381     else
 382         apply := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
 383 end;
 384
 385 function conj(Args: TMalArray) : TMal;
 386 var
 387     I    : longint;
 388     Vals : TMalArray;
 389 begin
 390     if Args[0] is TMalVector then
 391         conj := TMalVector.Create(_concat((Args[0] as TMalList).Val,
 392                                           copy(Args, 1, Length(Args))))
 393     else if Args[0] is TMalList then
 394     begin
 395         SetLength(Vals, Length(Args)-1);
 396         for I := 1 to Length(Args)-1 do
 397             Vals[I-1] := Args[Length(Args) - I];
 398         conj := TMalList.Create(_concat(Vals, (Args[0] as TMalList).Val));
 399     end
 400     else
 401         raise Exception.Create('conj: called on non-sequence');
 402 end;
 403 function seq(Args: TMalArray) : TMal;
 404 var
 405     Str : string;
 406     Arr : TMalArray;
 407     I   : longint;
 408 begin
 409     if Args[0] is TMalVector then
 410     begin
 411         if Length((Args[0] as TMalVector).Val) = 0 then
 412             Exit(TMalNil.Create);
 413         seq := TMalList.Create((Args[0] as TMalVector).Val);
 414     end
 415     else if Args[0] is TMalList then
 416     begin
 417         if Length((Args[0] as TMalList).Val) = 0 then
 418             Exit(TMalNil.Create);
 419         seq := Args[0]
 420     end
 421     else if _string_Q(Args[0]) then
 422     begin
 423         Str := (Args[0] as TMalString).Val;
 424         if Length(Str) = 0 then
 425             Exit(TMalNil.Create);
 426         SetLength(Arr, Length(Str));
 427         for I := 0 to Length(Str) do
 428             Arr[I] := TMalString.Create(Str[I+1]);
 429         seq := TMalList.Create(Arr);
 430     end
 431     else if Args[0] is TMalNil then
 432     begin
 433         seq := Args[0];
 434     end
 435     else
 436         raise Exception.Create('seq: called on non-sequence');
 437 end;
 438
 439
 440 // Metadata functions
 441
 442 function meta(Args: TMalArray) : TMal;
 443 begin
 444     if Args[0] is TMalFunc then
 445         meta := (Args[0] as TMalFunc).Meta
 446     else if Args[0] is TMalList then
 447         meta := (Args[0] as TMalList).Meta
 448     else if Args[0] is TMalHashMap then
 449         meta := (Args[0] as TMalHashMap).Meta
 450     else
 451         raise Exception.Create('meta not supported on ' + Args[0].ClassName);
 452
 453     if meta = nil then
 454         meta := TMalNil.Create;
 455 end;
 456 function with_meta(Args: TMalArray) : TMal;
 457 var
 458     Fn  : TMalFunc;
 459     Vec : TMalVector;
 460     Lst : TMalList;
 461     HM  : TMalHashMap;
 462 begin
 463     if Args[0] is TMalFunc then
 464     begin
 465         Fn := TMalFunc.Clone(Args[0] as TMalFunc);
 466         Fn.Meta := Args[1];
 467         with_meta := Fn;
 468     end
 469     else if Args[0] is TMalVector then
 470     begin
 471         Vec := TMalVector.Clone(Args[0] as TMalVector);
 472         Vec.Meta := Args[1];
 473         with_meta := Vec;
 474     end
 475     else if Args[0] is TMalList then
 476     begin
 477         Lst := TMalList.Clone(Args[0] as TMalList);
 478         Lst.Meta := Args[1];
 479         with_meta := Lst;
 480     end
 481     else if Args[0] is TMalHashMap then
 482     begin
 483         HM := TMalHashMap.Clone(Args[0] as TMalHashMap);
 484         HM.Meta := Args[1];
 485         with_meta := HM;
 486     end
 487     else
 488         raise Exception.Create('with-meta call on non-mal function');
 489 end;
 490
 491 // Atom functions
 492
 493 function atom(Args: TMalArray) : TMal;
 494 begin
 495     atom := TMalAtom.Create(Args[0]);
 496 end;
 497 function atom_Q(Args: TMalArray) : TMal;
 498 begin
 499     atom_Q := wrap_tf(Args[0] is TMalAtom);
 500 end;
 501 function deref(Args: TMalArray) : TMal;
 502 begin
 503     deref := (Args[0] as TMalAtom).Val;
 504 end;
 505 function reset_BANG(Args: TMalArray) : TMal;
 506 begin
 507     (Args[0] as TMalAtom).Val := Args[1];
 508     reset_BANG := Args[1];
 509 end;
 510
 511 function swap_BANG(Args: TMalArray) : TMal;
 512 var
 513     Atm   : TMalAtom;
 514     Fn    : TMalFunc;
 515     FArgs : TMalArray;
 516     I     : longint;
 517 begin
 518     Atm := (Args[0] as TMalAtom);
 519     Fn := (Args[1] as TMalFunc);
 520     SetLength(FArgs, Length(Args)-1);
 521     FArgs[0] := Atm.Val;
 522     for I := 1 to Length(Args)-2 do
 523         FArgs[I] := Args[I+1];
 524
 525     if Fn.Ast = nil then
 526         Atm.Val := Fn.Val(FArgs)
 527     else
 528         Atm.Val := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
 529     swap_BANG := Atm.Val;
 530 end;
 531
 532
 533 ////////////////////////////////////////////////////////////
 534
 535 initialization
 536 begin
 537     NS := TCoreDict.Create;
 538     NS['='] := @equal_Q;
 539     NS['throw'] := @throw;
 540
 541     NS['nil?'] := @nil_Q;
 542     NS['true?'] := @true_Q;
 543     NS['false?'] := @false_Q;
 544     NS['string?'] := @string_Q;
 545     NS['symbol'] := @symbol;
 546     NS['symbol?'] := @symbol_Q;
 547     NS['keyword'] := @keyword;
 548     NS['keyword?'] := @keyword_Q;
 549
 550     NS['pr-str'] := @do_pr_str;
 551     NS['str'] := @str;
 552     NS['prn'] := @prn;
 553     NS['println'] := @println;
 554     NS['read-string'] := @read_string;
 555     NS['readline'] := @do_readline;
 556     NS['slurp'] := @slurp;
 557
 558     NS['<'] := @lt;
 559     NS['<='] := @lte;
 560     NS['>'] := @gt;
 561     NS['>='] := @gte;
 562     NS['+'] := @add;
 563     NS['-'] := @subtract;
 564     NS['*'] := @multiply;
 565     NS['/'] := @divide;
 566     NS['time-ms'] := @time_ms;
 567
 568     NS['list'] := @list;
 569     NS['list?'] := @list_Q;
 570     NS['vector'] := @vector;
 571     NS['vector?'] := @vector_Q;
 572     NS['hash-map'] := @hash_map;
 573     NS['map?'] := @map_Q;
 574     NS['assoc'] := @assoc;
 575     NS['dissoc'] := @dissoc;
 576     NS['get'] := @get;
 577     NS['contains?'] := @contains_Q;
 578     NS['keys'] := @keys;
 579     NS['vals'] := @vals;
 580
 581     NS['sequential?'] := @sequential_Q;
 582     NS['cons'] := @cons;
 583     NS['concat'] := @do_concat;
 584     NS['nth'] := @nth;
 585     NS['first'] := @first;
 586     NS['rest'] := @rest;
 587     NS['empty?'] := @empty_Q;
 588     NS['count'] := @count;
 589     NS['apply'] := @apply;
 590     NS['map'] := @map;
 591
 592     NS['conj'] := @conj;
 593     NS['seq'] := @seq;
 594
 595     NS['meta'] := @meta;
 596     NS['with-meta'] := @with_meta;
 597     NS['atom'] := @atom;
 598     NS['atom?'] := @atom_Q;
 599     NS['deref'] := @deref;
 600     NS['reset!'] := @reset_BANG;
 601     NS['swap!'] := @swap_BANG;
 602 end
 603
 604 end.