objpascal/step5_tco.pas

   1 program Mal;
   2
   3 {$H+} // Use AnsiString
   4
   5 Uses sysutils,
   6      CMem,
   7      fgl,
   8      mal_readline,
   9      mal_types,
  10      mal_func,
  11      reader,
  12      printer,
  13      mal_env,
  14      core;
  15
  16 var
  17     Repl_Env : TEnv;
  18     Line     : string;
  19     I        : longint;
  20     Key      : string;
  21
  22 // read
  23 function READ(const Str: string) : TMal;
  24 begin
  25     READ := read_str(Str);
  26 end;
  27
  28 // eval
  29 // Forward declation since eval_ast call it
  30 function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
  31
  32 function eval_ast(Ast: TMal; Env: TEnv) : TMal;
  33 var
  34     OldArr, NewArr   : TMalArray;
  35     OldDict, NewDict : TMalDict;
  36     I                : longint;
  37 begin
  38     if Ast is TMalSymbol then
  39     begin
  40         eval_ast := Env.Get((Ast as TMalSymbol));
  41     end
  42     else if Ast is TMalList then
  43     begin
  44         OldArr := (Ast as TMalList).Val;
  45         SetLength(NewArr, Length(OldArr));
  46         for I := 0 to Length(OldArr)-1 do
  47         begin
  48             NewArr[I] := EVAL(OldArr[I], Env);
  49         end;
  50         if Ast is TMalVector then
  51             eval_ast := TMalVector.Create(NewArr)
  52         else
  53             eval_ast := TMalList.Create(NewArr);
  54     end
  55     else if Ast is TMalHashMap then
  56     begin
  57         OldDict := (Ast as TMalHashMap).Val;
  58         NewDict := TMalDict.Create;
  59         I := 0;
  60         while I < OldDict.Count do
  61         begin
  62             NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
  63             I := I + 1;
  64         end;
  65         eval_ast := TMalHashMap.Create(NewDict);
  66     end
  67     else
  68         eval_ast := Ast;
  69 end;
  70
  71 function EVAL(Ast: TMal; Env: TEnv) : TMal;
  72 var
  73     Lst    : TMalList;
  74     Arr    : TMalArray;
  75     Arr1   : TMalArray;
  76     A0Sym  : string;
  77     LetEnv : TEnv;
  78     Cond   : TMal;
  79     I      : longint;
  80     Fn     : TMalFunc;
  81     Args   : TMalArray;
  82 begin
  83   while true do
  84   begin
  85     if Ast.ClassType <> TMalList then
  86         Exit(eval_ast(Ast, Env));
  87
  88     // Apply list
  89     Lst := (Ast as TMalList);
  90     Arr := Lst.Val;
  91     if Length(Arr) = 0 then
  92         Exit(Ast);
  93     if Arr[0] is TMalSymbol then
  94         A0Sym := (Arr[0] as TMalSymbol).Val
  95     else
  96         A0Sym := '__<*fn*>__';
  97
  98     case A0Sym of
  99     'def!':
 100         Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)));
 101     'let*':
 102         begin
 103             LetEnv := TEnv.Create(Env);
 104             Arr1 := (Arr[1] as TMalList).Val;
 105             I := 0;
 106             while I < Length(Arr1) do
 107             begin
 108                 LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv));
 109                 Inc(I,2);
 110             end;
 111             Env := LetEnv;
 112             Ast := Arr[2]; // TCO
 113         end;
 114     'do':
 115         begin
 116             eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
 117             Ast := Arr[Length(Arr)-1]; // TCO
 118         end;
 119     'if':
 120         begin
 121             Cond := EVAL(Arr[1], Env);
 122             if (Cond is TMalNil) or (Cond is TMalFalse) then
 123                 if Length(Arr) > 3 then
 124                     Ast := Arr[3] // TCO
 125                 else
 126                     Exit(TMalNil.Create)
 127             else
 128                 Ast := Arr[2]; // TCO
 129         end;
 130     'fn*':
 131         begin
 132             Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList)));
 133         end;
 134     else
 135         begin
 136             Arr := (eval_ast(Ast, Env) as TMalList).Val;
 137             if Arr[0] is TMalFunc then
 138             begin
 139                 Fn := Arr[0] as TMalFunc;
 140                 if Length(Arr) < 2 then
 141                     SetLength(Args, 0)
 142                 else
 143                     Args := copy(Arr, 1, Length(Arr)-1);
 144                 if Fn.Ast = nil then
 145                     Exit(Fn.Val(Args))
 146                 else
 147                 begin
 148                     Env := TEnv.Create(Fn.Env, Fn.Params, Args);
 149                     Ast := Fn.Ast; // TCO
 150                 end
 151
 152             end
 153             else
 154                 raise Exception.Create('invalid apply');
 155         end;
 156     end;
 157   end;
 158 end;
 159
 160 // print
 161 function PRINT(Exp: TMal) : string;
 162 begin
 163     PRINT := pr_str(Exp, True);
 164 end;
 165
 166 // repl
 167 function REP(Str: string) : string;
 168 begin
 169     REP := PRINT(EVAL(READ(Str), Repl_Env));
 170 end;
 171
 172 begin
 173     Repl_Env := TEnv.Create;
 174
 175     // core.pas: defined using Pascal
 176     for I := 0 to core.NS.Count-1 do
 177     begin
 178         Key := core.NS.Keys[I];
 179         Repl_Env.Add(TMalSymbol.Create(Key),
 180                      TMalFunc.Create(core.NS[Key]));
 181     end;
 182
 183     // core.mal: defined using language itself
 184     REP('(def! not (fn* (a) (if a false true)))');
 185
 186     while True do
 187     begin
 188         try
 189             Line := _readline('user> ');
 190             if Line = '' then continue;
 191             WriteLn(REP(Line))
 192         except
 193             On E : MalEOF do Halt(0);
 194             On E : Exception do
 195             begin
 196                 WriteLn('Error: ' + E.message);
 197                 WriteLn('Backtrace:');
 198                 WriteLn(GetBacktrace(E));
 199             end;
 200         end;
 201     end;
 202 end.