objpascal/step4_if_fn_do.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     FnEnv  : TEnv;
  79     Cond   : TMal;
  80     I      : longint;
  81     Fn     : TMalFunc;
  82     Args   : TMalArray;
  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 Length(Arr) = 0 then
  91         Exit(Ast);
  92     if Arr[0] is TMalSymbol then
  93         A0Sym := (Arr[0] as TMalSymbol).Val
  94     else
  95         A0Sym := '__<*fn*>__';
  96
  97     case A0Sym of
  98     'def!':
  99         EVAL := Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV));
 100     'let*':
 101         begin
 102             LetEnv := TEnv.Create(Env);
 103             Arr1 := (Arr[1] as TMalList).Val;
 104             I := 0;
 105             while I < Length(Arr1) do
 106             begin
 107                 LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv));
 108                 Inc(I,2);
 109             end;
 110             EVAL := EVAL(Arr[2], LetEnv);
 111         end;
 112     'do':
 113         begin
 114             Arr := (eval_ast(Lst.Rest, Env) as TMalList).Val;
 115             EVAL := Arr[Length(Arr)-1];
 116         end;
 117     'if':
 118         begin
 119             Cond := EVAL(Arr[1], Env);
 120             if (Cond is TMalNil) or (Cond is TMalFalse) then
 121                 if Length(Arr) > 3 then
 122                     EVAL := EVAL(Arr[3], Env)
 123                 else
 124                     EVAL := TMalNil.Create
 125             else
 126                 EVAL := EVAL(Arr[2], Env);
 127         end;
 128     'fn*':
 129         begin
 130             EVAL := TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))
 131         end;
 132     else
 133         begin
 134             Arr := (eval_ast(Ast, Env) as TMalList).Val;
 135             if Arr[0] is TMalFunc then
 136             begin
 137                 Fn := Arr[0] as TMalFunc;
 138                 if Length(Arr) < 2 then
 139                     SetLength(Args, 0)
 140                 else
 141                     Args := copy(Arr, 1, Length(Arr)-1);
 142                 if Fn.Ast = nil then
 143                     EVAL := Fn.Val(Args)
 144                 else
 145                 begin
 146                     FnEnv := TEnv.Create(Fn.Env, Fn.Params, Args);
 147                     EVAL := EVAL(Fn.Ast, FnEnv);
 148                 end
 149
 150             end
 151             else
 152                 raise Exception.Create('invalid apply');
 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         try
 186             Line := _readline('user> ');
 187             if Line = '' then continue;
 188             WriteLn(REP(Line))
 189         except
 190             On E : MalEOF do Halt(0);
 191             On E : Exception do
 192             begin
 193                 WriteLn('Error: ' + E.message);
 194                 WriteLn('Backtrace:');
 195                 WriteLn(GetBacktrace(E));
 196             end;
 197         end;
 198     end;
 199 end.