objpascal/step5_tco.pas

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