2016-03-13 16:59:46 -05:00
|
|
|
program Mal;
|
|
|
|
|
|
2016-03-14 00:07:01 -05:00
|
|
|
{$H+} // Use AnsiString
|
|
|
|
|
|
2016-03-13 16:59:46 -05:00
|
|
|
Uses sysutils,
|
|
|
|
|
fgl,
|
|
|
|
|
math,
|
2016-03-14 00:07:01 -05:00
|
|
|
mal_readline,
|
2016-03-13 16:59:46 -05:00
|
|
|
mal_types,
|
|
|
|
|
mal_func,
|
|
|
|
|
reader,
|
|
|
|
|
printer,
|
|
|
|
|
mal_env,
|
|
|
|
|
core;
|
|
|
|
|
|
|
|
|
|
var
|
|
|
|
|
Repl_Env : TEnv;
|
2016-03-14 00:07:01 -05:00
|
|
|
Line : string;
|
2016-03-13 16:59:46 -05:00
|
|
|
I : longint;
|
|
|
|
|
Key : string;
|
|
|
|
|
CmdArgs : TMalArray;
|
|
|
|
|
|
|
|
|
|
// read
|
|
|
|
|
function READ(const Str: string) : TMal;
|
|
|
|
|
begin
|
|
|
|
|
READ := read_str(Str);
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
// eval
|
2020-07-21 18:01:48 +02:00
|
|
|
|
|
|
|
|
function starts_with(Ast: TMal; Sym: String) : Boolean;
|
|
|
|
|
var
|
|
|
|
|
Arr : TMalArray;
|
|
|
|
|
A0 : TMal;
|
2016-03-13 16:59:46 -05:00
|
|
|
begin
|
2020-07-21 18:01:48 +02:00
|
|
|
if Ast.ClassType <> TMalList then Exit (False);
|
|
|
|
|
Arr := (Ast as TMalList).Val;
|
|
|
|
|
if Length (Arr) = 0 then Exit (False);
|
|
|
|
|
A0 := Arr [0];
|
|
|
|
|
starts_with := (A0.ClassType = TMalSymbol) and ((A0 as TMalSymbol).Val = Sym);
|
2016-03-13 16:59:46 -05:00
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
function quasiquote(Ast: TMal) : TMal;
|
|
|
|
|
var
|
2020-07-21 18:01:48 +02:00
|
|
|
Arr : TMalArray;
|
|
|
|
|
Res, Elt : TMal;
|
|
|
|
|
I : longint;
|
2016-03-13 16:59:46 -05:00
|
|
|
begin
|
2020-07-21 18:01:48 +02:00
|
|
|
if Ast is TMalSymbol or Ast is TMalHashMap then
|
|
|
|
|
Exit(_list(TMalSymbol.Create('quote'), Ast));
|
|
|
|
|
|
|
|
|
|
if not (Ast is TMalList) then
|
|
|
|
|
Exit(Ast);
|
|
|
|
|
|
|
|
|
|
Arr := (Ast as TMalList).Val;
|
|
|
|
|
if starts_with (Ast, 'unquote') then Exit(Arr[1]);
|
|
|
|
|
|
|
|
|
|
Res := _list();
|
|
|
|
|
for I := 1 to Length(Arr) do
|
2016-03-13 16:59:46 -05:00
|
|
|
begin
|
2020-07-21 18:01:48 +02:00
|
|
|
Elt := Arr [Length(Arr) - I];
|
|
|
|
|
if starts_with (Elt, 'splice-unquote') then
|
|
|
|
|
Res := _list(TMalSymbol.Create('concat'), (Elt as TMalList).Val[1], Res)
|
|
|
|
|
else
|
|
|
|
|
Res := _list(TMalSymbol.Create('cons'), quasiquote (Elt), Res);
|
2016-03-13 16:59:46 -05:00
|
|
|
end;
|
2020-07-21 18:01:48 +02:00
|
|
|
if Ast.ClassType <> TMalList then
|
|
|
|
|
Exit(_list(TMalSymbol.Create('vec'), Res))
|
|
|
|
|
else
|
|
|
|
|
Exit(Res);
|
2016-03-13 16:59:46 -05:00
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
function EVAL(Ast: TMal; Env: TEnv) : TMal;
|
|
|
|
|
var
|
|
|
|
|
Lst : TMalList;
|
|
|
|
|
Arr : TMalArray;
|
|
|
|
|
Arr1 : TMalArray;
|
|
|
|
|
A0Sym : string;
|
|
|
|
|
LetEnv : TEnv;
|
|
|
|
|
Cond : TMal;
|
|
|
|
|
I : longint;
|
|
|
|
|
Fn : TMalFunc;
|
|
|
|
|
Args : TMalArray;
|
|
|
|
|
Err : TMalArray;
|
2022-01-10 00:15:40 +01:00
|
|
|
OldDict, NewDict : TMalDict;
|
2016-03-13 16:59:46 -05:00
|
|
|
begin
|
|
|
|
|
while true do
|
|
|
|
|
begin
|
|
|
|
|
|
2022-01-10 00:15:40 +01:00
|
|
|
Cond := Env.Get('DEBUG-EVAL');
|
|
|
|
|
if (Cond <> nil) and not (Cond is TMalNil) and not (Cond is TMalFalse) then
|
|
|
|
|
WriteLn('EVAL: ' + pr_str(Ast, True));
|
|
|
|
|
|
|
|
|
|
if Ast is TMalSymbol then
|
|
|
|
|
begin
|
|
|
|
|
A0Sym := (Ast as TMalSymbol).Val;
|
|
|
|
|
Cond := Env.Get(A0Sym);
|
|
|
|
|
if Cond = nil then
|
|
|
|
|
raise Exception.Create('''' + A0Sym+ ''' not found');
|
|
|
|
|
Exit(Cond);
|
|
|
|
|
end
|
|
|
|
|
else if Ast is TMalVector then
|
|
|
|
|
begin
|
|
|
|
|
Arr := (Ast as TMalVector).Val;
|
|
|
|
|
SetLength(Arr1, Length(Arr));
|
|
|
|
|
for I := 0 to Length(Arr)-1 do
|
|
|
|
|
Arr1[I]:= EVAL(Arr[I], Env);
|
|
|
|
|
Exit(TMalVector.Create(Arr1));
|
|
|
|
|
end
|
|
|
|
|
else if Ast is TMalHashMap then
|
|
|
|
|
begin
|
|
|
|
|
OldDict := (Ast as TMalHashMap).Val;
|
|
|
|
|
NewDict := TMalDict.Create;
|
|
|
|
|
for I := 0 to OldDict.Count-1 do
|
|
|
|
|
NewDict[OldDict.Keys[I]]:= EVAL(OldDict[OldDict.Keys[I]], Env);
|
|
|
|
|
Exit(TMalHashMap.Create(NewDict));
|
|
|
|
|
end
|
|
|
|
|
else if not (Ast is TMalList) then
|
|
|
|
|
Exit(Ast);
|
2016-03-13 16:59:46 -05:00
|
|
|
|
|
|
|
|
// Apply list
|
|
|
|
|
Lst := (Ast as TMalList);
|
|
|
|
|
Arr := Lst.Val;
|
2016-04-02 17:27:43 -05:00
|
|
|
if Length(Arr) = 0 then
|
|
|
|
|
Exit(Ast);
|
2016-03-13 16:59:46 -05:00
|
|
|
if Arr[0] is TMalSymbol then
|
|
|
|
|
A0Sym := (Arr[0] as TMalSymbol).Val
|
|
|
|
|
else
|
|
|
|
|
A0Sym := '__<*fn*>__';
|
|
|
|
|
|
|
|
|
|
case A0Sym of
|
|
|
|
|
'def!':
|
|
|
|
|
Exit(Env.Add((Arr[1] as TMalSymbol), EVAL(Arr[2], ENV)));
|
|
|
|
|
'let*':
|
|
|
|
|
begin
|
|
|
|
|
LetEnv := TEnv.Create(Env);
|
|
|
|
|
Arr1 := (Arr[1] as TMalList).Val;
|
|
|
|
|
I := 0;
|
|
|
|
|
while I < Length(Arr1) do
|
|
|
|
|
begin
|
|
|
|
|
LetEnv.Add((Arr1[I] as TMalSymbol), EVAL(Arr1[I+1], LetEnv));
|
|
|
|
|
Inc(I,2);
|
|
|
|
|
end;
|
|
|
|
|
Env := LetEnv;
|
|
|
|
|
Ast := Arr[2]; // TCO
|
|
|
|
|
end;
|
|
|
|
|
'quote':
|
|
|
|
|
Exit(Arr[1]);
|
|
|
|
|
'quasiquote':
|
|
|
|
|
Ast := quasiquote(Arr[1]);
|
|
|
|
|
'defmacro!':
|
|
|
|
|
begin
|
|
|
|
|
Fn := EVAL(Arr[2], ENV) as TMalFunc;
|
2021-08-16 10:07:20 +02:00
|
|
|
Fn := TMalFunc.Clone(Fn);
|
2016-03-13 16:59:46 -05:00
|
|
|
Fn.isMacro := true;
|
|
|
|
|
Exit(Env.Add((Arr[1] as TMalSymbol), Fn));
|
|
|
|
|
end;
|
|
|
|
|
'try*':
|
|
|
|
|
begin
|
|
|
|
|
try
|
|
|
|
|
Exit(EVAL(Arr[1], Env));
|
|
|
|
|
except
|
|
|
|
|
On E : Exception do
|
|
|
|
|
begin
|
2019-02-27 17:06:14 -06:00
|
|
|
if Length(Arr) < 3 then
|
|
|
|
|
raise;
|
2016-03-13 16:59:46 -05:00
|
|
|
SetLength(Err, 1);
|
|
|
|
|
if E.ClassType = TMalException then
|
|
|
|
|
Err[0] := (E as TMalException).Val
|
|
|
|
|
else
|
|
|
|
|
Err[0] := TMalString.Create(E.message);
|
|
|
|
|
Arr := (Arr[2] as TMalList).Val;
|
|
|
|
|
Exit(EVAL(Arr[2], TEnv.Create(Env,
|
|
|
|
|
_list(Arr[1]),
|
|
|
|
|
Err)));
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
'do':
|
|
|
|
|
begin
|
2022-01-10 00:15:40 +01:00
|
|
|
for I := 1 to Length(Arr) - 2 do
|
|
|
|
|
Cond := EVAL(Arr[I], Env);
|
2016-03-13 16:59:46 -05:00
|
|
|
Ast := Arr[Length(Arr)-1]; // TCO
|
|
|
|
|
end;
|
|
|
|
|
'if':
|
|
|
|
|
begin
|
|
|
|
|
Cond := EVAL(Arr[1], Env);
|
|
|
|
|
if (Cond is TMalNil) or (Cond is TMalFalse) then
|
|
|
|
|
if Length(Arr) > 3 then
|
|
|
|
|
Ast := Arr[3] // TCO
|
|
|
|
|
else
|
|
|
|
|
Exit(TMalNil.Create)
|
|
|
|
|
else
|
|
|
|
|
Ast := Arr[2]; // TCO
|
|
|
|
|
end;
|
|
|
|
|
'fn*':
|
|
|
|
|
begin
|
|
|
|
|
Exit(TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList)));
|
|
|
|
|
end;
|
|
|
|
|
else
|
|
|
|
|
begin
|
2022-01-10 00:15:40 +01:00
|
|
|
Cond := EVAL(Arr[0], Env);
|
|
|
|
|
Args := copy(Arr, 1, Length(Arr) - 1);
|
|
|
|
|
if Cond is TMalFunc then
|
2016-03-13 16:59:46 -05:00
|
|
|
begin
|
2022-01-10 00:15:40 +01:00
|
|
|
Fn := Cond as TMalFunc;
|
|
|
|
|
if Fn.isMacro then
|
|
|
|
|
begin
|
|
|
|
|
if Fn.Ast =nil then
|
|
|
|
|
Ast := Fn.Val(Args)
|
|
|
|
|
else
|
|
|
|
|
Ast := EVAL(Fn.Ast, Tenv.Create(Fn.Env, Fn.Params, Args));
|
|
|
|
|
continue; // TCO
|
|
|
|
|
end;
|
|
|
|
|
for I := 0 to Length(Args) - 1 do
|
|
|
|
|
Args[I]:= EVAL(Args[I], Env);
|
2016-03-13 16:59:46 -05:00
|
|
|
if Fn.Ast = nil then
|
|
|
|
|
Exit(Fn.Val(Args))
|
|
|
|
|
else
|
|
|
|
|
begin
|
|
|
|
|
Env := TEnv.Create(Fn.Env, Fn.Params, Args);
|
|
|
|
|
Ast := Fn.Ast; // TCO
|
|
|
|
|
end
|
|
|
|
|
|
|
|
|
|
end
|
|
|
|
|
else
|
|
|
|
|
raise Exception.Create('invalid apply');
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
// print
|
|
|
|
|
function PRINT(Exp: TMal) : string;
|
|
|
|
|
begin
|
|
|
|
|
PRINT := pr_str(Exp, True);
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
// repl
|
|
|
|
|
function REP(Str: string) : string;
|
|
|
|
|
begin
|
|
|
|
|
REP := PRINT(EVAL(READ(Str), Repl_Env));
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
function do_eval(Args : TMalArray) : TMal;
|
|
|
|
|
begin
|
|
|
|
|
do_eval := EVAL(Args[0], Repl_Env);
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
begin
|
|
|
|
|
Repl_Env := TEnv.Create;
|
|
|
|
|
core.EVAL := @EVAL;
|
|
|
|
|
|
|
|
|
|
// core.pas: defined using Pascal
|
|
|
|
|
for I := 0 to core.NS.Count-1 do
|
|
|
|
|
begin
|
|
|
|
|
Key := core.NS.Keys[I];
|
|
|
|
|
Repl_Env.Add(TMalSymbol.Create(Key),
|
|
|
|
|
TMalFunc.Create(core.NS[Key]));
|
|
|
|
|
end;
|
|
|
|
|
Repl_Env.Add(TMalSymbol.Create('eval'), TMalFunc.Create(@do_eval));
|
|
|
|
|
SetLength(CmdArgs, Max(0, ParamCount-1));
|
|
|
|
|
for I := 2 to ParamCount do
|
|
|
|
|
CmdArgs[I-2] := TMalString.Create(ParamStr(I));
|
|
|
|
|
Repl_Env.Add(TMalSymbol.Create('*ARGV*'), TMalList.Create(CmdArgs));
|
|
|
|
|
Repl_Env.Add(TMalSymbol.Create('*host-language*'),
|
|
|
|
|
TMalString.Create('Object Pascal'));
|
|
|
|
|
|
|
|
|
|
// core.mal: defined using language itself
|
|
|
|
|
REP('(def! not (fn* (a) (if a false true)))');
|
2019-07-15 23:57:02 +02:00
|
|
|
REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) "\nnil)")))))');
|
2016-03-13 16:59:46 -05:00
|
|
|
REP('(defmacro! cond (fn* (& xs) (if (> (count xs) 0) (list ''if (first xs) (if (> (count xs) 1) (nth xs 1) (throw "odd number of forms to cond")) (cons ''cond (rest (rest xs)))))))');
|
|
|
|
|
|
|
|
|
|
|
|
|
|
|
if ParamCount >= 1 then
|
|
|
|
|
begin
|
|
|
|
|
REP('(load-file "' + ParamStr(1) + '")');
|
|
|
|
|
ExitCode := 0;
|
|
|
|
|
Exit;
|
|
|
|
|
end;
|
|
|
|
|
|
|
|
|
|
REP('(println (str "Mal [" *host-language* "]"))');
|
|
|
|
|
while True do
|
|
|
|
|
begin
|
|
|
|
|
try
|
2016-03-14 00:07:01 -05:00
|
|
|
Line := _readline('user> ');
|
|
|
|
|
if Line = '' then continue;
|
2016-03-13 16:59:46 -05:00
|
|
|
WriteLn(REP(Line))
|
|
|
|
|
except
|
2016-03-14 00:07:01 -05:00
|
|
|
On E : MalEOF do Halt(0);
|
2016-03-13 16:59:46 -05:00
|
|
|
On E : Exception do
|
|
|
|
|
begin
|
Test uncaught throw, catchless try* . Fix 46 impls.
Fixes made to: ada, c, chuck, clojure, coffee, common-lisp, cpp,
crystal, d, dart, elm, erlang, es6, factor, fsharp, gnu-smalltalk,
groovy, guile, haxe, hy, js, livescript, matlab, miniMAL, nasm, nim,
objc, objpascal, ocaml, perl, perl6, php, plsql, ps, python, r,
rpython, ruby, scheme, swift3, tcl, ts, vb, vimscript, wasm, yorick.
Catchless try* test is an optional test. Not all implementations
support catchless try* but a number were fixed so they at least don't
crash on catchless try*.
2018-12-03 13:20:44 -06:00
|
|
|
if E.ClassType = TMalException then
|
|
|
|
|
WriteLn('Error: ' + pr_str((E as TMalException).Val, True))
|
|
|
|
|
else
|
|
|
|
|
WriteLn('Error: ' + E.message);
|
2016-03-13 16:59:46 -05:00
|
|
|
WriteLn('Backtrace:');
|
|
|
|
|
WriteLn(GetBacktrace(E));
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
end;
|
|
|
|
|
end.
|
