- Move vector related step4 and step6 tests to optional.
- Fix two step9 tests that weren't checking return value.
ocaml/*.cmx
ocaml/*.o
ocaml/mal_lib.*
+objpascal/*.o
+objpascal/*.ppu
+objpascal/pas-readline
+objpascal/regexpr
perl/mal.pl
php/mal.php
ps/mal.ps
# Settings
#
-IMPLS = awk bash c d clojure coffee cpp crystal cs erlang elisp elixir es6 \
- factor forth fsharp go groovy guile haskell haxe io java julia \
- js kotlin lua make mal ocaml matlab miniMAL nim objc perl php ps \
- python r racket rpython ruby rust scala swift swift3 tcl vb vimscript
+IMPLS = awk bash c d clojure coffee cpp crystal cs erlang elisp \
+ elixir es6 factor forth fsharp go groovy guile haskell haxe \
+ io java julia js kotlin lua make mal ocaml matlab miniMAL \
+ nim objc objpascal perl php ps python r racket rpython ruby \
+ rust scala swift swift3 tcl vb vimscript
step0 = step0_repl
step1 = step1_read_print
STEP5_EXCLUDES += miniMAL # strange error with runtest.py
STEP5_EXCLUDES += nim # test completes, even at 100,000
STEP5_EXCLUDES += objc # completes at 10,000, crashes at 100,000
+STEP5_EXCLUDES += objpascal # completes at 10,000
STEP5_EXCLUDES += php # test completes, even at 100,000
STEP5_EXCLUDES += racket # test completes
STEP5_EXCLUDES += ruby # test completes, even at 100,000
STEP5_EXCLUDES += rust # no catching stack overflows
-STEP5_EXCLUDES += swift3 # no catching stack overflows
+STEP5_EXCLUDES += swift3 # no catching stack overflows
STEP5_EXCLUDES += ocaml # test completes, even at 1,000,000
STEP5_EXCLUDES += vb # completes at 10,000
miniMAL_STEP_TO_PROG = miniMAL/$($(1)).json
nim_STEP_TO_PROG = nim/$($(1))
objc_STEP_TO_PROG = objc/$($(1))
+objpascal_STEP_TO_PROG = objpascal/$($(1))
perl_STEP_TO_PROG = perl/$($(1)).pl
php_STEP_TO_PROG = php/$($(1)).php
ps_STEP_TO_PROG = ps/$($(1)).ps
miniMAL_RUNSTEP = miniMAL ../$(2) $(3)
nim_RUNSTEP = ../$(2) $(3)
objc_RUNSTEP = ../$(2) $(3)
+objpascal_RUNSTEP = ../$(2) $(3)
perl_RUNSTEP = perl ../$(2) $(3)
php_RUNSTEP = php ../$(2) $(3)
ps_RUNSTEP = gs -q -I./ -dNODISPLAY -- ../$(2) $(3)
* MATLAB
* [miniMAL](https://github.com/kanaka/miniMAL)
* Nim
+* Object Pascal
* Objective C
* OCaml
* Perl
./stepX_YYY
```
+### Object Pascal
+
+The Object Pascal implementation of mal has been built and tested on
+Linux using the Free Pascal compiler version 2.6.2 and 2.6.4.
+
+```
+cd objpascal
+make
+./stepX_YYY
+```
+
### Objective C
The Objective C implementation of mal has been built and tested on
--- /dev/null
+FROM ubuntu:vivid
+MAINTAINER Joel Martin <github@martintribe.org>
+
+##########################################################
+# General requirements for testing or common across many
+# implementations
+##########################################################
+
+RUN apt-get -y update
+
+# Required for running tests
+RUN apt-get -y install make python
+
+# Some typical implementation and test requirements
+RUN apt-get -y install curl libreadline-dev libedit-dev
+
+RUN mkdir -p /mal
+WORKDIR /mal
+
+##########################################################
+# Specific implementation requirements
+##########################################################
+
+# Free Pascal
+RUN apt-get -y install libc6-dev fp-compiler
--- /dev/null
+STEPS = step0_repl.pas step1_read_print.pas step2_eval.pas \
+ step3_env.pas step4_if_fn_do.pas step5_tco.pas \
+ step6_file.pas step7_quote.pas step8_macros.pas \
+ step9_try.pas stepA_mal.pas
+
+STEP0_DEPS = pas-readline/src/readline.pas regexpr/Source/RegExpr.pas
+STEP1_DEPS = $(STEP0_DEPS) mal_types.pas reader.pas printer.pas
+STEP3_DEPS = $(STEP1_DEPS) mal_env.pas
+STEP4_DEPS = $(STEP3_DEPS) core.pas
+
+SOURCES = mal_types.pas mal_func.pas reader.pas printer.pas \
+ mal_env.pas core.pas stepA_mal.pas
+SOURCES_LISP = mal_env.pas core.pas stepA_mal.pas
+
+#####################
+
+DEBUG = -gl
+
+FPC = fpc -MOBJFPC -ve $(DEBUG) -Fupas-readline/src -Furegexpr/Source
+
+all: $(patsubst %.pas,%,$(STEPS))
+
+# Downloaded units
+pas-readline: pas-readline/src/readline.pas
+pas-readline/src/readline.pas:
+ git clone https://github.com/hansiglaser/pas-readline pas-readline
+
+regexpr: regexpr/Source/RegExpr.pas
+regexpr/Source/RegExpr.pas:
+ mkdir -p regexpr
+ curl -O http://regexpstudio.com/Downloads/regexpr.zip
+ cd regexpr && unzip ../regexpr.zip
+ rm regexpr.zip
+
+step%: step%.pas
+ $(FPC) $<
+
+step0_repl: $(STEP0_DEPS)
+step1_read_print step2_eval: $(STEP1_DEPS)
+step3_env: $(STEP3_DEPS)
+step4_if_fn_do step5_tco step6_file step7_quote step8_macros step9_try stepA_mal: $(STEP4_DEPS)
+
+clean:
+ rm -f $(STEPS:%.pas=%) *.o *.ppu regexpr/Source/*.o regexpr/Source/*.ppu mal
+
+.PHONY: stats stats-lisp
+
+stats: $(SOURCES)
+ @wc $^
+ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
+stats-lisp: $(SOURCES_LISP)
+ @wc $^
+ @printf "%5s %5s %5s %s\n" `grep -E "^[[:space:]]*//|^[[:space:]]*$$" $^ | wc` "[comments/blanks]"
+
--- /dev/null
+unit core;
+
+{$H+} // Use AnsiString
+
+interface
+
+uses Classes,
+ sysutils,
+ fgl,
+ Readline in 'pas-readline/src/readline.pas',
+ mal_types,
+ mal_func,
+ mal_env,
+ reader,
+ printer;
+
+type
+ TCoreDict = specialize TFPGMap<string,TMalCallable>;
+
+var
+ EVAL : function (A: TMal; E: TEnv) : TMal;
+ NS : TCoreDict;
+
+////////////////////////////////////////////////////////////
+
+implementation
+
+// General functions
+
+function equal_Q(Args: TMalArray) : TMal;
+begin
+ equal_Q := wrap_tf(_equal_Q(Args[0], Args[1]));
+end;
+
+function throw(Args: TMalArray) : TMal;
+begin
+ raise TMalException.Create(Args[0]);
+ throw := TMalNil.Create; // Not reached
+end;
+
+// Scalar functions
+
+function nil_Q(Args: TMalArray) : TMal;
+begin
+ nil_Q := wrap_tf(Args[0] is TMalNil);
+end;
+function true_Q(Args: TMalArray) : TMal;
+begin
+ true_Q := wrap_tf(Args[0] is TMalTrue);
+end;
+function false_Q(Args: TMalArray) : TMal;
+begin
+ false_Q := wrap_tf(Args[0] is TMalFalse);
+end;
+function string_Q(Args: TMalArray) : TMal;
+begin
+ string_Q := wrap_tf(_string_Q(Args[0]));
+end;
+function symbol(Args: TMalArray) : TMal;
+begin
+ if Args[0] is TMalSymbol then
+ symbol := Args[0]
+ else if Args[0] is TMalString then
+ symbol := TMalSymbol.Create((Args[0] as TMalString).Val)
+ else
+ raise Exception.Create('Invalid symbol call');
+end;
+function symbol_Q(Args: TMalArray) : TMal;
+begin
+ symbol_Q := wrap_tf(Args[0] is TMalSymbol);
+end;
+function keyword(Args: TMalArray) : TMal;
+begin
+ if ((Args[0] is TMalString) and not _string_Q(Args[0])) then
+ keyword := Args[0]
+ else if Args[0] is TMalString then
+ keyword := TMalString.Create(#127 + (Args[0] as TMalString).Val)
+ else
+ raise Exception.Create('Invalid keyword call');
+end;
+function keyword_Q(Args: TMalArray) : TMal;
+begin
+ keyword_Q := wrap_tf((Args[0] is TMalString) and not _string_Q(Args[0]));
+end;
+
+// String functions
+
+function do_pr_str(Args: TMalArray) : TMal;
+begin
+ do_pr_str := TMalString.Create(pr_str_array(Args, true, ' '));
+end;
+function str(Args: TMalArray) : TMal;
+begin
+ str := TMalString.Create(pr_str_array(Args, false, ''));
+end;
+function prn(Args: TMalArray) : TMal;
+begin
+ WriteLn(pr_str_array(Args, true, ' '));
+ prn := TMalNil.Create;
+end;
+function println(Args: TMalArray) : TMal;
+begin
+ WriteLn(pr_str_array(Args, false, ' '));
+ println := TMalNil.Create;
+end;
+
+function read_string(Args: TMalArray) : TMal;
+begin
+ read_string := read_str((Args[0] as TMalString).Val);
+end;
+function do_readline(Args: TMalArray) : TMal;
+var
+ Prompt : PChar;
+ Line : PChar;
+begin
+ Prompt := PChar((Args[0] as TMalString).Val);
+ Line := Readline.readline(Prompt);
+ if Line = nil then
+ do_readline := TMalNil.Create
+ else
+ do_readline := TMalString.Create(Line);
+end;
+function slurp(Args: TMalArray) : TMal;
+var
+ StrL : TStringList;
+begin
+ StrL := TStringList.Create;
+ StrL.LoadFromFile((Args[0] as TMalString).Val);
+ slurp := TMalString.Create(StrL.Text);
+end;
+
+// Math functions
+
+function lt(Args: TMalArray) : TMal;
+begin
+ lt := wrap_tf((Args[0] as TMalInt).Val < (Args[1] as TMalInt).Val);
+end;
+function lte(Args: TMalArray) : TMal;
+begin
+ lte := wrap_tf((Args[0] as TMalInt).Val <= (Args[1] as TMalInt).Val);
+end;
+function gt(Args: TMalArray) : TMal;
+begin
+ gt := wrap_tf((Args[0] as TMalInt).Val > (Args[1] as TMalInt).Val);
+end;
+function gte(Args: TMalArray) : TMal;
+begin
+ gte := wrap_tf((Args[0] as TMalInt).Val >= (Args[1] as TMalInt).Val);
+end;
+
+function add(Args: TMalArray) : TMal;
+begin
+ add := TMalInt.Create((Args[0] as TMalInt).Val +
+ (Args[1] as TMalInt).Val);
+end;
+function subtract(Args: TMalArray) : TMal;
+begin
+ subtract := TMalInt.Create((Args[0] as TMalInt).Val -
+ (Args[1] as TMalInt).Val);
+end;
+function multiply(Args: TMalArray) : TMal;
+begin
+ multiply := TMalInt.Create((Args[0] as TMalInt).Val *
+ (Args[1] as TMalInt).Val);
+end;
+function divide(Args: TMalArray) : TMal;
+begin
+ divide := TMalInt.Create((Args[0] as TMalInt).Val div
+ (Args[1] as TMalInt).Val);
+end;
+function time_ms(Args: TMalArray) : TMal;
+begin
+ time_ms := TMalInt.Create(Trunc(TimeStampToMSecs(DateTimeToTimeStamp(Now))));
+end;
+
+// Collection functions
+
+function list(Args: TMalArray) : TMal;
+begin
+ list := TMalList.Create(Args);
+end;
+function list_Q(Args: TMalArray) : TMal;
+begin
+ list_Q := wrap_tf(Args[0].ClassType = TMalList);
+end;
+function vector(Args: TMalArray) : TMal;
+begin
+ vector := TMalVector.Create(Args);
+end;
+function vector_Q(Args: TMalArray) : TMal;
+begin
+ vector_Q := wrap_tf(Args[0].ClassType = TMalVector);
+end;
+function hash_map(Args: TMalArray) : TMal;
+begin
+ hash_map := TMalHashMap.Create(Args);
+end;
+function map_Q(Args: TMalArray) : TMal;
+begin
+ map_Q := wrap_tf(Args[0].ClassType = TMalHashMap);
+end;
+function assoc(Args: TMalArray) : TMal;
+var
+ OrigHM, NewHM : TMalHashMap;
+begin
+ OrigHM := (Args[0] as TMalHashMap);
+ NewHM := TMalHashMap.Clone(OrigHM);
+ assoc := NewHM.assoc_BANG(copy(Args, 1, Length(Args)));
+end;
+function dissoc(Args: TMalArray) : TMal;
+var
+ OrigHM, NewHM : TMalHashMap;
+begin
+ OrigHM := (Args[0] as TMalHashMap);
+ NewHM := TMalHashMap.Clone(OrigHM);
+ dissoc := NewHM.dissoc_BANG(copy(Args, 1, Length(Args)));
+end;
+function get(Args: TMalArray) : TMal;
+var
+ HM : TMalHashMap;
+begin
+ if Args[0] is TMalNil then Exit(TMalNil.Create);
+ HM := (Args[0] as TMalHashMap);
+ if HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0 then
+ get := HM.Val[(Args[1] as TMalString).Val]
+ else
+ get := TMalNil.Create;
+end;
+function contains_Q(Args: TMalArray) : TMal;
+var
+ HM : TMalHashMap;
+begin
+ if Args[0] is TMalNil then Exit(TMalFalse.Create);
+ HM := (Args[0] as TMalHashMap);
+ contains_Q := wrap_tf(HM.Val.IndexOf((Args[1] as TMalString).Val) >= 0);
+end;
+function keys(Args: TMalArray) : TMal;
+var
+ Dict : TMalDict;
+ Arr : TMalArray;
+ I : longint;
+begin
+ Dict := (Args[0] as TMalHashMap).Val;
+ SetLength(Arr, Dict.Count);
+ for I := 0 to Dict.Count-1 do
+ Arr[I] := TMalString.Create(Dict.Keys[I]);
+ keys := TMalList.Create(Arr);
+end;
+function vals(Args: TMalArray) : TMal;
+var
+ Dict : TMalDict;
+ Arr : TMalArray;
+ I : longint;
+begin
+ Dict := (Args[0] as TMalHashMap).Val;
+ SetLength(Arr, Dict.Count);
+ for I := 0 to Dict.Count-1 do
+ Arr[I] := Dict[Dict.Keys[I]];
+ vals := TMalList.Create(Arr);
+end;
+
+
+// Sequence functions
+
+function sequential_Q(Args: TMalArray) : TMal;
+begin
+ sequential_Q := wrap_tf(_sequential_Q(Args[0]));
+end;
+function cons(Args: TMalArray) : TMal;
+var
+ Res, Src : TMalArray;
+ I : longint;
+begin
+ Src := (Args[1] as TMalList).Val;
+ SetLength(Res, 1 + Length(Src));
+ Res[0] := Args[0];
+ for I := 1 to Length(Src) do
+ Res[I] := Src[I-1];
+ cons := TMalList.Create(Res);
+end;
+function do_concat(Args: TMalArray) : TMal;
+var
+ Res : TMalArray;
+ I : longint;
+begin
+ SetLength(Res, 0);
+ for I := 0 to Length(Args)-1 do
+ begin
+ Res := _concat(Res, (Args[I] as TMalList).Val);
+ end;
+ do_concat := TMalList.Create(Res);
+end;
+function nth(Args: TMalArray) : TMal;
+var
+ Arr : TMalArray;
+ Idx : longint;
+begin
+ Arr := (Args[0] as TMalList).Val;
+ Idx := (Args[1] as TMalInt).Val;
+ if Idx >= Length(Arr) then
+ raise Exception.Create('nth: index out of range')
+ else
+ nth := Arr[Idx];
+end;
+function first(Args: TMalArray) : TMal;
+var
+ Arr : TMalArray;
+begin
+ if Args[0] is TMalNil then Exit(TMalNil.Create);
+ Arr := (Args[0] as TMalList).Val;
+ if Length(Arr) = 0 then
+ first := TMalNil.Create
+ else
+ first := (Args[0] as TMalList).Val[0];
+end;
+function rest(Args: TMalArray) : TMal;
+begin
+ if Args[0] is TMalNil then Exit(_list());
+ rest := (Args[0] as TMalList).Rest();
+end;
+
+function empty_Q(Args: TMalArray) : TMal;
+begin
+ if Args[0] is TMalNil then
+ empty_Q := TMalTrue.Create
+ else if Args[0] is TMalList then
+ empty_Q := wrap_tf(Length((Args[0] as TMalList).Val) = 0)
+ else raise Exception.Create('invalid empty? call');
+end;
+function count(Args: TMalArray) : TMal;
+begin
+ if Args[0] is TMalNil then
+ count := TMalInt.Create(0)
+ else if Args[0] is TMalList then
+ count := TMalInt.Create(Length((Args[0] as TMalList).Val))
+ else raise Exception.Create('invalid count call');
+end;
+
+function map(Args: TMalArray) : TMal;
+var
+ Fn : TMalFunc;
+ FArgs : TMalArray;
+ Src, Res : TMalArray;
+ I : longint;
+begin
+ Fn := (Args[0] as TMalFunc);
+ Src := (Args[1] as TMalList).Val;
+ SetLength(FArgs, 1);
+ SetLength(Res, Length(Src));
+ if Fn.Ast = nil then
+ for I := 0 to Length(Src)-1 do
+ begin
+ FArgs[0] := Src[I];
+ Res[I] := Fn.Val(FArgs);
+ end
+ else
+ for I := 0 to Length(Src)-1 do
+ begin
+ FArgs[0] := Src[I];
+ Res[I] := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
+ end;
+ map := TMalList.Create(Res);
+end;
+function apply(Args: TMalArray) : TMal;
+var
+ Fn : TMalFunc;
+ LastArgs : TMalArray;
+ FArgs : TMalArray;
+ I : longint;
+begin
+ Fn := (Args[0] as TMalFunc);
+ LastArgs := (Args[Length(Args)-1] as TMalList).Val;
+ SetLength(FArgs, Length(LastArgs) + Length(Args) - 2);
+ for I := 0 to Length(Args)-3 do
+ FArgs[I] := Args[I+1];
+ for I := 0 to Length(LastArgs)-1 do
+ FArgs[Length(Args)-2 + I] := LastArgs[I];
+ if Fn.Ast = nil then
+ apply := Fn.Val(FArgs)
+ else
+ apply := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
+end;
+
+function conj(Args: TMalArray) : TMal;
+var
+ I : longint;
+ Vals : TMalArray;
+begin
+ if Args[0] is TMalVector then
+ conj := TMalVector.Create(_concat((Args[0] as TMalList).Val,
+ copy(Args, 1, Length(Args))))
+ else if Args[0] is TMalList then
+ begin
+ SetLength(Vals, Length(Args)-1);
+ for I := 1 to Length(Args)-1 do
+ Vals[I-1] := Args[Length(Args) - I];
+ conj := TMalList.Create(_concat(Vals, (Args[0] as TMalList).Val));
+ end
+ else
+ raise Exception.Create('conj: called on non-sequence');
+end;
+function seq(Args: TMalArray) : TMal;
+var
+ Str : string;
+ Arr : TMalArray;
+ I : longint;
+begin
+ if Args[0] is TMalVector then
+ begin
+ if Length((Args[0] as TMalVector).Val) = 0 then
+ Exit(TMalNil.Create);
+ seq := TMalList.Create((Args[0] as TMalVector).Val);
+ end
+ else if Args[0] is TMalList then
+ begin
+ if Length((Args[0] as TMalList).Val) = 0 then
+ Exit(TMalNil.Create);
+ seq := Args[0]
+ end
+ else if _string_Q(Args[0]) then
+ begin
+ Str := (Args[0] as TMalString).Val;
+ if Length(Str) = 0 then
+ Exit(TMalNil.Create);
+ SetLength(Arr, Length(Str));
+ for I := 0 to Length(Str) do
+ Arr[I] := TMalString.Create(Str[I+1]);
+ seq := TMalList.Create(Arr);
+ end
+ else if Args[0] is TMalNil then
+ begin
+ seq := Args[0];
+ end
+ else
+ raise Exception.Create('seq: called on non-sequence');
+end;
+
+
+// Metadata functions
+
+function meta(Args: TMalArray) : TMal;
+begin
+ if Args[0] is TMalFunc then
+ meta := (Args[0] as TMalFunc).Meta
+ else if Args[0] is TMalList then
+ meta := (Args[0] as TMalList).Meta
+ else if Args[0] is TMalHashMap then
+ meta := (Args[0] as TMalHashMap).Meta
+ else
+ raise Exception.Create('meta not supported on ' + Args[0].ClassName);
+
+ if meta = nil then
+ meta := TMalNil.Create;
+end;
+function with_meta(Args: TMalArray) : TMal;
+var
+ Fn : TMalFunc;
+ Vec : TMalVector;
+ Lst : TMalList;
+ HM : TMalHashMap;
+begin
+ if Args[0] is TMalFunc then
+ begin
+ Fn := TMalFunc.Clone(Args[0] as TMalFunc);
+ Fn.Meta := Args[1];
+ with_meta := Fn;
+ end
+ else if Args[0] is TMalVector then
+ begin
+ Vec := TMalVector.Clone(Args[0] as TMalVector);
+ Vec.Meta := Args[1];
+ with_meta := Vec;
+ end
+ else if Args[0] is TMalList then
+ begin
+ Lst := TMalList.Clone(Args[0] as TMalList);
+ Lst.Meta := Args[1];
+ with_meta := Lst;
+ end
+ else if Args[0] is TMalHashMap then
+ begin
+ HM := TMalHashMap.Clone(Args[0] as TMalHashMap);
+ HM.Meta := Args[1];
+ with_meta := HM;
+ end
+ else
+ raise Exception.Create('with-meta call on non-mal function');
+end;
+
+// Atom functions
+
+function atom(Args: TMalArray) : TMal;
+begin
+ atom := TMalAtom.Create(Args[0]);
+end;
+function atom_Q(Args: TMalArray) : TMal;
+begin
+ atom_Q := wrap_tf(Args[0] is TMalAtom);
+end;
+function deref(Args: TMalArray) : TMal;
+begin
+ deref := (Args[0] as TMalAtom).Val;
+end;
+function reset_BANG(Args: TMalArray) : TMal;
+begin
+ (Args[0] as TMalAtom).Val := Args[1];
+ reset_BANG := Args[1];
+end;
+
+function swap_BANG(Args: TMalArray) : TMal;
+var
+ Atm : TMalAtom;
+ Fn : TMalFunc;
+ FArgs : TMalArray;
+ I : longint;
+begin
+ Atm := (Args[0] as TMalAtom);
+ Fn := (Args[1] as TMalFunc);
+ SetLength(FArgs, Length(Args)-1);
+ FArgs[0] := Atm.Val;
+ for I := 1 to Length(Args)-2 do
+ FArgs[I] := Args[I+1];
+
+ if Fn.Ast = nil then
+ Atm.Val := Fn.Val(FArgs)
+ else
+ Atm.Val := EVAL(Fn.Ast, TEnv.Create(Fn.Env, Fn.Params, FArgs));
+ swap_BANG := Atm.Val;
+end;
+
+
+////////////////////////////////////////////////////////////
+
+initialization
+begin
+ NS := TCoreDict.Create;
+ NS['='] := @equal_Q;
+ NS['throw'] := @throw;
+
+ NS['nil?'] := @nil_Q;
+ NS['true?'] := @true_Q;
+ NS['false?'] := @false_Q;
+ NS['string?'] := @string_Q;
+ NS['symbol'] := @symbol;
+ NS['symbol?'] := @symbol_Q;
+ NS['keyword'] := @keyword;
+ NS['keyword?'] := @keyword_Q;
+
+ NS['pr-str'] := @do_pr_str;
+ NS['str'] := @str;
+ NS['prn'] := @prn;
+ NS['println'] := @println;
+ NS['read-string'] := @read_string;
+ NS['readline'] := @do_readline;
+ NS['slurp'] := @slurp;
+
+ NS['<'] := @lt;
+ NS['<='] := @lte;
+ NS['>'] := @gt;
+ NS['>='] := @gte;
+ NS['+'] := @add;
+ NS['-'] := @subtract;
+ NS['*'] := @multiply;
+ NS['/'] := @divide;
+ NS['time-ms'] := @time_ms;
+
+ NS['list'] := @list;
+ NS['list?'] := @list_Q;
+ NS['vector'] := @vector;
+ NS['vector?'] := @vector_Q;
+ NS['hash-map'] := @hash_map;
+ NS['map?'] := @map_Q;
+ NS['assoc'] := @assoc;
+ NS['dissoc'] := @dissoc;
+ NS['get'] := @get;
+ NS['contains?'] := @contains_Q;
+ NS['keys'] := @keys;
+ NS['vals'] := @vals;
+
+ NS['sequential?'] := @sequential_Q;
+ NS['cons'] := @cons;
+ NS['concat'] := @do_concat;
+ NS['nth'] := @nth;
+ NS['first'] := @first;
+ NS['rest'] := @rest;
+ NS['empty?'] := @empty_Q;
+ NS['count'] := @count;
+ NS['apply'] := @apply;
+ NS['map'] := @map;
+
+ NS['conj'] := @conj;
+ NS['seq'] := @seq;
+
+ NS['meta'] := @meta;
+ NS['with-meta'] := @with_meta;
+ NS['atom'] := @atom;
+ NS['atom?'] := @atom_Q;
+ NS['deref'] := @deref;
+ NS['reset!'] := @reset_BANG;
+ NS['swap!'] := @swap_BANG;
+end
+
+end.
--- /dev/null
+unit mal_env;
+
+{$H+} // Use AnsiString
+
+interface
+
+Uses sysutils,
+ fgl,
+ mal_types;
+
+type TEnv = class(TObject)
+ public
+ Data : TMalDict;
+ Outer : TEnv;
+
+ constructor Create;
+ constructor Create(_Outer : TEnv);
+ constructor Create(_Outer : TEnv;
+ Binds : TMalList;
+ Exprs : TMalArray);
+
+ function Add(Key : TMalSymbol; Val : TMal) : TMal;
+ function Find(Key : TMalSymbol) : TEnv;
+ function Get(Key : TMalSymbol) : TMal;
+end;
+
+////////////////////////////////////////////////////////////
+
+implementation
+
+constructor TEnv.Create();
+begin
+ inherited Create();
+ Self.Data := TMalDict.Create;
+ Self.Outer := nil;
+end;
+
+constructor TEnv.Create(_Outer: TEnv);
+begin
+ Self.Create();
+ Self.Outer := _Outer;
+end;
+
+constructor TEnv.Create(_Outer : TEnv;
+ Binds : TMalList;
+ Exprs : TMalArray);
+var
+ I : longint;
+ Bind : TMalSymbol;
+ Rest : TMalList;
+begin
+ Self.Create(_Outer);
+ for I := 0 to Length(Binds.Val)-1 do
+ begin
+ Bind := (Binds.Val[I] as TMalSymbol);
+ if Bind.Val = '&' then
+ begin
+ if I < Length(Exprs) then
+ Rest := TMalList.Create(copy(Exprs, I, Length(Exprs)-I))
+ else
+ Rest := TMalList.Create;
+ Self.Data[(Binds.Val[I+1] as TMalSymbol).Val] := Rest;
+ break;
+ end;
+ Self.Data[Bind.Val] := Exprs[I];
+ end;
+end;
+
+function TEnv.Add(Key : TMalSymbol; Val : TMal) : TMal;
+begin
+ Self.Data[Key.Val] := Val;
+ Add := Val;
+end;
+
+function TEnv.Find(Key : TMalSymbol) : TEnv;
+var
+ Sym : string;
+begin
+ Sym := (Key as TMalSymbol).Val;
+ if Data.IndexOf(Sym) >= 0 then
+ Find := Self
+ else if Outer <> nil then
+ Find := Outer.Find(Key)
+ else
+ Find := nil;
+end;
+
+function TEnv.Get(Key : TMalSymbol) : TMal;
+var
+ Sym : string;
+ Env : TEnv;
+begin
+ Sym := (Key as TMalSymbol).Val;
+ Env := Self.Find(Key);
+ if Env <> nil then
+ Get := Env.Data[Sym]
+ else
+ raise Exception.Create('''' + Sym + ''' not found');
+end;
+
+end.
--- /dev/null
+unit mal_func;
+
+interface
+
+uses mal_types,
+ mal_env;
+
+// Some general type definitions
+
+type
+ TMalCallable = function (Args : TMalArray) : TMal;
+
+type TMalFunc = class(TMal)
+ public
+ Val : TMalCallable;
+ Ast : TMal;
+ Env : TEnv;
+ Params : TMalList;
+ isMacro : Boolean;
+ Meta : TMal;
+
+ constructor Create(V : TMalCallable);
+ constructor Create(A : TMal;
+ E : TEnv;
+ P : TMalList);
+
+ constructor Clone(F : TMalFunc);
+end;
+
+////////////////////////////////////////////////////////////
+
+implementation
+
+constructor TMalFunc.Create(V : TMalCallable);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+constructor TMalFunc.Create(A : TMal;
+ E : TEnv;
+ P : TMalList);
+begin
+ inherited Create();
+ Self.Ast := A;
+ Self.Env := E;
+ Self.Params := P;
+end;
+
+constructor TMalFunc.Clone(F : TMalFunc);
+begin
+ Self.Create(F.Ast, F.Env, F.Params);
+ Self.isMacro := F.isMacro;
+ Self.Meta := F.Meta;
+end;
+
+end.
--- /dev/null
+unit mal_types;
+
+{$H+} // Use AnsiString
+
+interface
+
+uses sysutils,
+ fgl;
+
+// Ancestor of all Mal types
+
+type TMal = class(TObject);
+
+
+// Some general type definitions
+
+type
+ TMalArray = array of TMal;
+ // TODO: use http://bugs.freepascal.org/view.php?id=27206 when
+ // incorporated into FPC
+ TMalDict = specialize TFPGMap<string,TMal>;
+
+type TMalException = class(Exception)
+ public
+ Val: TMal;
+
+ constructor Create(V : TMal);
+end;
+
+
+// Mal types
+
+type TMalNil = class(TMal);
+type TMalTrue = class(TMal);
+type TMalFalse = class(TMal);
+
+type TMalInt = class(TMal)
+ public
+ Val: Longint;
+
+ constructor Create(V : Longint);
+end;
+
+type TMalString = class(TMal)
+ public
+ Val: string;
+
+ constructor Create(V : string);
+end;
+
+type TMalSymbol = class(TMal)
+ public
+ Val: string;
+
+ constructor Create(V : string);
+end;
+
+
+type TMalList = class(TMal)
+ public
+ Val: TMalArray;
+ Meta: TMal;
+
+ constructor Create();
+ constructor Create(V : TMalArray);
+ function Rest() : TMalList;
+
+ constructor Clone(L : TMalList);
+end;
+
+type TMalVector = class(TMalList)
+end;
+
+type TMalAtom = class(TMal)
+ public
+ Val: TMal;
+
+ constructor Create(V : TMal);
+end;
+
+type TMalHashMap = class(TMal)
+ public
+ Val: TMalDict;
+ Meta: TMal;
+
+ constructor Create();
+ constructor Create(V : TMalDict);
+ constructor Create(V : TMalArray);
+
+ constructor Clone(HM : TMalHashMap);
+
+ function assoc_BANG(KVs: TMalArray) : TMal;
+ function dissoc_BANG(Ks: TMalArray) : TMal;
+end;
+
+
+// General type functions
+
+function GetBacktrace(E: Exception) : string;
+
+function wrap_tf(x : Boolean) : TMal;
+
+function _equal_Q(A : TMal; B : TMal) : Boolean;
+
+function _sequential_Q(Obj: TMal) : Boolean;
+
+function _list() : TMalList;
+function _list(A: TMal) : TMalList;
+function _list(A: TMal; B: TMal) : TMalList;
+function _list(A: TMal; B: TMal; C: TMal) : TMalList;
+
+function _concat(A: TMalArray; B: TMalArray) : TMalArray;
+
+function _string_Q(Obj: TMal) : Boolean;
+
+////////////////////////////////////////////////////////////
+
+implementation
+
+constructor TMalException.Create(V : TMal);
+begin
+ inherited Create('MalException');
+ Self.Val := V;
+end;
+
+//
+// Mal types
+//
+
+constructor TMalInt.Create(V : Longint);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+constructor TMalString.Create(V : string);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+constructor TMalSymbol.Create(V : string);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+constructor TMalList.Create();
+begin
+ inherited Create();
+ SetLength(Self.Val, 0);
+end;
+
+constructor TMalList.Create(V : TMalArray);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+constructor TMalList.Clone(L : TMalList);
+begin
+ inherited Create();
+ Self.Val := copy(L.Val, 0, Length(L.Val));
+end;
+
+
+function TMalList.Rest() : TMalList;
+begin
+ if Length(Val) <= 1 then
+ Rest := (_list() as TMalList)
+ else
+ Rest := TMalList.Create(copy(Val, 1, Length(Val)-1));
+end;
+
+// Hash Maps
+
+constructor TMalHashMap.Create();
+begin
+ inherited Create();
+ Self.Val := TMalDict.Create;
+end;
+
+constructor TMalHashMap.Create(V : TMalDict);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+function TMalHashMap.assoc_BANG(KVs: TMalArray) : TMal;
+var
+ I : longint;
+begin
+ I := 0;
+ while I < Length(KVs) do
+ begin
+ Self.Val[(KVs[I] as TMalString).Val] := KVs[I+1];
+ I := I + 2;
+ end;
+ assoc_BANG := Self;
+end;
+
+function TMalHashMap.dissoc_BANG(Ks: TMalArray) : TMal;
+var
+ I : longint;
+begin
+ for I := 0 to Length(Ks)-1 do
+ Self.Val.Remove((Ks[I] as TMalString).Val);
+ dissoc_BANG := Self;
+end;
+
+
+constructor TMalHashMap.Create(V : TMalArray);
+begin
+ Self.Create();
+ Self.assoc_BANG(V);
+end;
+
+constructor TMalHashMap.Clone(HM : TMalHashMap);
+var
+ I : longint;
+begin
+ Self.Create();
+ I := 0;
+ while I < HM.Val.Count do
+ begin
+ Self.Val[HM.Val.Keys[I]] := HM.Val[HM.Val.Keys[I]];
+ I := I + 1;
+ end;
+end;
+
+
+// Atoms
+
+constructor TMalAtom.Create(V : TMal);
+begin
+ inherited Create();
+ Self.Val := V;
+end;
+
+//
+// General type functions
+//
+
+function GetBacktrace(E: Exception) : string;
+var
+ I: Integer;
+ Frames: PPointer;
+begin
+ GetBacktrace := BackTraceStrFunc(ExceptAddr);
+ Frames := ExceptFrames;
+ for I := 0 to ExceptFrameCount - 1 do
+ GetBacktrace := GetBacktrace + #10 + BackTraceStrFunc(Frames[I]);
+end;
+
+function wrap_tf(x : Boolean) : TMal;
+begin
+ if x = true then wrap_tf := TMalTrue.Create
+ else wrap_tf := TMalFalse.Create;
+end;
+
+function _equal_Q(A : TMal; B : TMal) : Boolean;
+var
+ I : longint;
+ ArrA, ArrB : TMalArray;
+ DictA, DictB : TMalDict;
+ Key : string;
+begin
+ if not ((A.ClassType = B.ClassType) or
+ ((A is TMalList) and (B is TMalList))) then
+ _equal_Q := false
+ else
+ begin
+ if A is TMalList then
+ begin
+ ArrA := (A as TMalList).Val;
+ ArrB := (B as TMalList).Val;
+ if Length(ArrA) <> Length(ArrB) then
+ Exit(false);
+ for I := 0 to Length(ArrA)-1 do
+ if not _equal_Q(ArrA[I], ArrB[I]) then
+ Exit(false);
+ _equal_Q := true;
+ end
+ else if A is TMalHashMap then
+ begin
+ DictA := (A as TMalHashMap).Val;
+ DictB := (B as TMalHashMap).Val;
+ if DictA.Count <> DictB.Count then
+ Exit(false);
+ for I := 0 to DictA.Count-1 do
+ begin
+ Key := DictA.Keys[I];
+ if DictB.IndexOf(Key) < 0 then
+ Exit(false);
+ if not _equal_Q(DictA[Key], DictB[Key]) then
+ Exit(false);
+ end;
+ _equal_Q := true;
+ end
+ else if A is TMalString then
+ _equal_Q := (A as TMalString).Val = (B as TMalString).Val
+ else if A is TMalSymbol then
+ _equal_Q := (A as TMalSymbol).Val = (B as TMalSymbol).Val
+ else if A is TMalInt then
+ _equal_Q := (A as TMalInt).Val = (B as TMalInt).Val
+ else if A is TMalNil then
+ _equal_Q := B is TMalNil
+ else if A is TMalTrue then
+ _equal_Q := B is TMalTrue
+ else if A is TMalFalse then
+ _equal_Q := B is TMalFalse
+ else
+ _equal_Q := A = B;
+ end
+end;
+
+function _sequential_Q(Obj: TMal) : Boolean;
+begin
+ _sequential_Q := Obj is TMalList;
+end;
+
+
+function _list() : TMalList;
+var
+ Arr: TMalArray;
+begin
+ SetLength(Arr, 0);
+ _list := TMalList.Create(Arr);
+end;
+
+function _list(A: TMal) : TMalList;
+var
+ Arr: TMalArray;
+begin
+ SetLength(Arr, 1);
+ Arr[0] := A;
+ _list := TMalList.Create(Arr);
+end;
+
+function _list(A: TMal; B: TMal) : TMalList;
+var
+ Arr: TMalArray;
+begin
+ SetLength(Arr, 2);
+ Arr[0] := A;
+ Arr[1] := B;
+ _list := TMalList.Create(Arr);
+end;
+
+function _list(A: TMal; B: TMal; C: TMal) : TMalList;
+var
+ Arr: TMalArray;
+begin
+ SetLength(Arr, 3);
+ Arr[0] := A;
+ Arr[1] := B;
+ Arr[2] := C;
+ _list := TMalList.Create(Arr);
+end;
+
+function _concat(A: TMalArray; B: TMalArray) : TMalArray;
+var
+ Res : TMalArray;
+ I : longint;
+begin
+ SetLength(Res, Length(A) + Length(B));
+ for I := 0 to Length(A)-1 do
+ Res[I] := A[I];
+ for I := 0 to Length(B)-1 do
+ Res[I+Length(A)] := B[I];
+ _concat := Res;
+end;
+
+function _string_Q(Obj: TMal) : Boolean;
+var
+ Str : string;
+begin
+ if (Obj is TMalString) then
+ begin
+ Str := (Obj as TMalString).Val;
+ _string_Q := (Length(Str) = 0) or (Str[1] <> #127)
+ end
+ else
+ _string_Q := false;
+end;
+
+end.
--- /dev/null
+unit printer;
+
+{$H+} // Use AnsiString
+
+interface
+
+Uses sysutils,
+ mal_types,
+ mal_func;
+
+function pr_str_array(Args : TMalArray;
+ print_readably : Boolean;
+ Separator : string) : string;
+
+function pr_str(Obj : TMal; print_readably : Boolean) : string;
+
+implementation
+
+function pr_str_array(Args : TMalArray;
+ print_readably : Boolean;
+ Separator : string) : string;
+var
+ Str : string;
+ I : longint;
+begin
+ Str := '';
+ for I := 0 to Length(Args)-1 do
+ begin
+ Str := Str + pr_str(Args[I], print_readably);
+ if I <> Length(Args)-1 then
+ Str := Str + Separator;
+ end;
+ pr_str_array := Str;
+end;
+
+function pr_str_dict(Dict : TMalDict;
+ print_readably : Boolean;
+ Separator : string) : string;
+var
+ I : longint;
+ Arr : TMalArray;
+begin
+ SetLength(Arr, Dict.Count * 2);
+ I := 0;
+ while I < Dict.Count do
+ begin
+ Arr[I*2] := TMalString.Create(Dict.Keys[I]);
+ Arr[I*2+1] := Dict[Dict.Keys[I]];
+ I := I + 1;
+ end;
+ pr_str_dict := pr_str_array(Arr, print_readably, ' ');
+end;
+
+
+function pr_str(Obj : TMal; print_readably : Boolean) : string;
+var
+ Str : string;
+ Fn : TMalFunc;
+begin
+ if Obj.ClassType = TMalList then
+ pr_str := '(' + pr_str_array((Obj as TMalList).Val,
+ print_readably,
+ ' ') + ')'
+ else if Obj.ClassType = TMalVector then
+ pr_str := '[' + pr_str_array((Obj as TMalList).Val,
+ print_readably,
+ ' ') + ']'
+ else if Obj is TMalHashMap then
+ pr_str := '{' + pr_str_dict((Obj as TMalHashMap).Val,
+ print_readably,
+ ' ') + '}'
+ else if Obj is TMalString then
+ begin
+ Str := (Obj as TMalString).Val;
+ if (Length(Str) > 0) and (Str[1] = #127) then
+ pr_str := ':' + copy(Str, 2, Length(Str))
+ else if print_readably then
+ begin
+ Str := StringReplace(Str, '\', '\\', [rfReplaceAll]);
+ Str := StringReplace(Str, '"', '\"', [rfReplaceAll]);
+ Str := StringReplace(Str, #10, '\n', [rfReplaceAll]);
+ pr_str := Format('"%s"', [Str])
+ end
+ else
+ pr_str := Str;
+ end
+ else if Obj is TMalNil then
+ pr_str := 'nil'
+ else if Obj is TMalTrue then
+ pr_str := 'true'
+ else if Obj is TMalFalse then
+ pr_str := 'false'
+ else if Obj is TMalInt then
+ pr_str := IntToStr((Obj as TMalInt).Val)
+ else if Obj is TMalSymbol then
+ pr_str := (Obj as TMalSymbol).Val
+ else if Obj is TMalAtom then
+ pr_str := '(atom ' +
+ pr_str((Obj as TMalAtom).Val, print_readably) +
+ ')'
+ else if Obj is TMalFunc then
+ begin
+ Fn := (Obj as TMalFunc);
+ if Fn.Ast = nil then
+ pr_str := '#<native function>'
+ else
+ pr_str := '(fn* ' + pr_str(Fn.Params,true) +
+ ' ' + pr_str(Fn.Ast,true) + ')'
+ end
+ else
+ pr_str := '#unknown';
+end;
+
+end.
--- /dev/null
+unit reader;
+
+{$H+} // Use AnsiString
+
+interface
+
+Uses sysutils,
+ Classes,
+ RegExpr in 'regexpr/Source/RegExpr.pas',
+ mal_types;
+
+//
+// Reader class
+//
+
+type TReader = class(TObject)
+ public
+ Tokens : TStringList;
+ Position : Integer;
+
+ constructor Create(Toks: TStringList);
+
+ function Peek() : string;
+ function Next() : string;
+end;
+
+//
+// reader functions
+//
+
+function read_str(const Str: string): TMal;
+
+
+implementation
+
+//
+// Reader class
+//
+
+constructor TReader.Create(Toks: TStringList);
+begin
+ inherited Create();
+ Self.Tokens := Toks;
+ Self.Position := 0;
+end;
+
+function TReader.Peek() : string;
+begin
+ if Position >= Tokens.Count then
+ Peek := #0
+ else
+ Peek := Tokens[Position];
+end;
+
+function TReader.Next() : string;
+begin
+ Next := Tokens[Position];
+ Position := Position + 1;
+end;
+
+
+//
+// reader functions
+//
+
+function tokenize(const Str: string) : TStringList;
+var
+ RE : TRegExpr;
+ Tokens : TStringList;
+begin
+ RE := TRegExpr.Create;
+ RE.Expression := '[\s,]*(~@|[\[\]{}()''`~^@]|"(([\\].|[^\\"])*)"?|;[^\r\n]*|[^\s\[\]{}()''"`@,;]+)';
+ Tokens := TStringList.Create;
+ if RE.Exec(Str) then
+ begin
+ repeat
+ if RE.Match[1][1] <> ';' then
+ Tokens.Add(RE.Match[1]);
+ until not RE.ExecNext;
+ end;
+ RE.Free;
+
+ tokenize := Tokens;
+end;
+
+
+function read_atom(Reader : TReader) : TMal;
+var
+ RE : TRegExpr;
+ Token : string;
+ Str : string;
+begin
+ RE := TRegExpr.Create;
+ RE.Expression := '(^-?[0-9]+$)|(^-?[0-9][0-9.]*$)|(^nil$)|(^true$)|(^false$)|^(\".*\")$|:(.*)|(^[^\"]*$)';
+ Token := Reader.Next();
+ //WriteLn('token: ' + Token);
+ if RE.Exec(Token) then
+ begin
+ if RE.Match[1] <> '' then
+ read_atom := TMalInt.Create(StrToInt(RE.Match[1]))
+ else if RE.Match[2] <> '' then
+ // TODO
+ read_atom := TMalNil.Create
+ else if RE.Match[3] <> '' then
+ read_atom := TMalNil.Create
+ else if RE.Match[4] <> '' then
+ read_atom := TMalTrue.Create
+ else if RE.Match[5] <> '' then
+ read_atom := TMalFalse.Create
+ else if RE.Match[6] <> '' then
+ begin
+ Str := copy(Token, 2, Length(Token)-2);
+ Str := StringReplace(Str, '\"', '"', [rfReplaceAll]);
+ Str := StringReplace(Str, '\n', #10, [rfReplaceAll]);
+ Str := StringReplace(Str, '\\', '\', [rfReplaceAll]);
+ read_atom := TMalString.Create(Str)
+ end
+ else if RE.Match[7] <> '' then
+ read_atom := TMalString.Create(#127 + RE.Match[7])
+ else if RE.Match[8] <> '' then
+ read_atom := TMalSymbol.Create(Token);
+ end
+ else
+ begin
+ RE.Free;
+ raise Exception.Create('Invalid token in read_atom');
+ end;
+ RE.Free;
+end;
+
+// Forward declaration since read_seq calls it
+function read_form(Reader : TReader) : TMal; forward;
+
+function read_seq(Reader : TReader; start: string; last: string) : TMalArray;
+var
+ Token : string;
+ Ast : TMalArray;
+begin
+ SetLength(Ast, 0);
+
+ Token := Reader.Next();
+ if Token <> start then
+ raise Exception.Create('expected ''' + start + '''');
+
+ Token := Reader.Peek();
+ while Token <> last do
+ begin
+ if Token = #0 then
+ raise Exception.Create('expected ''' + last + ''', got EOF');
+ SetLength(Ast, Length(Ast)+1);
+ Ast[Length(Ast)-1] := read_form(Reader);
+ Token := Reader.Peek();
+ end;
+
+ Token := Reader.Next();
+ read_seq := Ast;
+end;
+
+function read_form(Reader : TReader) : TMal;
+var
+ Token : string;
+ Meta : TMal;
+begin
+ Token := Reader.Peek();
+ case Token of
+ // reader macros/transforms
+ '''':
+ begin
+ Reader.Next();
+ read_form := _list(TMalSymbol.Create('quote'),
+ read_form(Reader));
+ end;
+ '`':
+ begin
+ Reader.Next();
+ read_form := _list(TMalSymbol.Create('quasiquote'),
+ read_form(Reader));
+ end;
+ '~':
+ begin
+ Reader.Next();
+ read_form := _list(TMalSymbol.Create('unquote'),
+ read_form(Reader));
+ end;
+ '~@':
+ begin
+ Reader.Next();
+ read_form := _list(TMalSymbol.Create('splice-unquote'),
+ read_form(Reader));
+ end;
+ '^':
+ begin
+ Reader.Next();
+ Meta := read_form(Reader);
+ read_form := _list(TMalSymbol.Create('with-meta'),
+ read_form(Reader),
+ Meta);
+ end;
+ '@':
+ begin
+ Reader.Next();
+ read_form := _list(TMalSymbol.Create('deref'), read_form(Reader));
+ end;
+
+ // list
+ ')': raise Exception.Create('unexpected '')''');
+ '(': read_form := TMalList.Create(read_seq(Reader, '(', ')'));
+
+ // vector
+ ']': raise Exception.Create('unexpected '']''');
+ '[': read_form := TMalVector.Create(read_seq(Reader, '[', ']'));
+
+ // hash-map
+ '}': raise Exception.Create('unexpected ''}''');
+ '{': read_form := TMalHashMap.Create(read_seq(Reader, '{', '}'));
+ else
+ read_form := read_atom(Reader);
+ end;
+end;
+
+
+function read_str(const Str: string): TMal;
+var
+ Tokens : TStringList;
+ //Dict : TObjectDictionary;
+begin
+ Tokens := tokenize(Str);
+ // TODO: check for empty list
+ read_str := read_form(TReader.Create(Tokens));
+end;
+
+end.
--- /dev/null
+program Mal;
+
+Uses CMem,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas';
+
+var
+ Repl_Env: string = '';
+ Line : PChar;
+
+// read
+function READ(const Str: string) : string;
+begin
+ READ := Str;
+end;
+
+// eval
+function EVAL(Ast: string; Env: string) : string;
+begin
+ EVAL := Ast;
+end;
+
+// print
+function PRINT(Exp: string) : string;
+begin
+ PRINT := Exp;
+end;
+
+// repl
+function REP(Str: string) : string;
+begin
+ REP := PRINT(EVAL(READ(Str), Repl_Env));
+end;
+
+begin
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ WriteLn(REP(Line));
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ reader,
+ printer;
+
+var
+ Repl_Env: string = '';
+ Line : PChar;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+function EVAL(Ast: TMal; Env: string) : TMal;
+begin
+ EVAL := Ast;
+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;
+
+begin
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+{$H+} // Use AnsiString
+
+Uses sysutils,
+ CMem,
+ fgl,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer;
+
+type
+ TEnv = specialize TFPGMap<string,TMal>;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ Sym : string;
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ Sym := (Ast as TMalSymbol).Val;
+ if Env.IndexOf(Sym) < 0 then
+ raise Exception.Create('''' + Sym + ''' not found')
+ else
+ eval_ast := Env[Sym];
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+end;
+
+function EVAL(Ast: TMal; Env: TEnv) : TMal;
+var
+ Arr : TMalArray;
+ Fn : TMalCallable;
+begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := (Arr[0] as TMalFunc).Val;
+ EVAL := Fn(copy(Arr, 1, Length(Arr)-1));
+ end
+ else
+ raise Exception.Create('invalid apply');
+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 add(Args: TMalArray) : TMal;
+begin
+ add := TMalInt.Create((Args[0] as TMalInt).Val +
+ (Args[1] as TMalInt).Val);
+end;
+function subtract(Args: TMalArray) : TMal;
+begin
+ subtract := TMalInt.Create((Args[0] as TMalInt).Val -
+ (Args[1] as TMalInt).Val);
+end;
+function multiply(Args: TMalArray) : TMal;
+begin
+ multiply := TMalInt.Create((Args[0] as TMalInt).Val *
+ (Args[1] as TMalInt).Val);
+end;
+function divide(Args: TMalArray) : TMal;
+begin
+ divide := TMalInt.Create((Args[0] as TMalInt).Val div
+ (Args[1] as TMalInt).Val);
+end;
+
+begin
+ Repl_Env := TEnv.Create;
+ Repl_Env.Add('+', TMalFunc.Create(@add));
+ Repl_Env.Add('-', TMalFunc.Create(@subtract));
+ Repl_Env.Add('*', TMalFunc.Create(@multiply));
+ Repl_Env.Add('/', TMalFunc.Create(@divide));
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+end;
+
+function EVAL(Ast: TMal; Env: TEnv) : TMal;
+var
+ Arr : TMalArray;
+ Arr1 : TMalArray;
+ A0Sym : string;
+ LetEnv : TEnv;
+ I : longint;
+ Fn : TMalCallable;
+begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Arr := (Ast as TMalList).Val;
+ if Arr[0] is TMalSymbol then
+ A0Sym := (Arr[0] as TMalSymbol).Val
+ else
+ A0Sym := '__<*fn*>__';
+
+ case A0Sym of
+ 'def!':
+ EVAL := 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;
+ EVAL := EVAL(Arr[2], LetEnv);
+ end;
+ else
+ begin
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := (Arr[0] as TMalFunc).Val;
+ EVAL := Fn(copy(Arr, 1, Length(Arr)-1));
+ end
+ else
+ raise Exception.Create('invalid apply');
+ 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 add(Args: TMalArray) : TMal;
+begin
+ add := TMalInt.Create((Args[0] as TMalInt).Val +
+ (Args[1] as TMalInt).Val);
+end;
+function subtract(Args: TMalArray) : TMal;
+begin
+ subtract := TMalInt.Create((Args[0] as TMalInt).Val -
+ (Args[1] as TMalInt).Val);
+end;
+function multiply(Args: TMalArray) : TMal;
+begin
+ multiply := TMalInt.Create((Args[0] as TMalInt).Val *
+ (Args[1] as TMalInt).Val);
+end;
+function divide(Args: TMalArray) : TMal;
+begin
+ divide := TMalInt.Create((Args[0] as TMalInt).Val div
+ (Args[1] as TMalInt).Val);
+end;
+
+begin
+ Repl_Env := TEnv.Create;
+ Repl_Env.Add(TMalSymbol.Create('+'), TMalFunc.Create(@add));
+ Repl_Env.Add(TMalSymbol.Create('-'), TMalFunc.Create(@subtract));
+ Repl_Env.Add(TMalSymbol.Create('*'), TMalFunc.Create(@multiply));
+ Repl_Env.Add(TMalSymbol.Create('/'), TMalFunc.Create(@divide));
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+end;
+
+function EVAL(Ast: TMal; Env: TEnv) : TMal;
+var
+ Lst : TMalList;
+ Arr : TMalArray;
+ Arr1 : TMalArray;
+ A0Sym : string;
+ LetEnv : TEnv;
+ FnEnv : TEnv;
+ Cond : TMal;
+ I : longint;
+ Fn : TMalFunc;
+ Args : TMalArray;
+begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ if Arr[0] is TMalSymbol then
+ A0Sym := (Arr[0] as TMalSymbol).Val
+ else
+ A0Sym := '__<*fn*>__';
+
+ case A0Sym of
+ 'def!':
+ EVAL := 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;
+ EVAL := EVAL(Arr[2], LetEnv);
+ end;
+ 'do':
+ begin
+ Arr := (eval_ast(Lst.Rest, Env) as TMalList).Val;
+ EVAL := Arr[Length(Arr)-1];
+ end;
+ 'if':
+ begin
+ Cond := EVAL(Arr[1], Env);
+ if (Cond is TMalNil) or (Cond is TMalFalse) then
+ if Length(Arr) > 3 then
+ EVAL := EVAL(Arr[3], Env)
+ else
+ EVAL := TMalNil.Create
+ else
+ EVAL := EVAL(Arr[2], Env);
+ end;
+ 'fn*':
+ begin
+ EVAL := TMalFunc.Create(Arr[2], Env, (Arr[1] as TMalList))
+ end;
+ else
+ begin
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ if Fn.Ast = nil then
+ EVAL := Fn.Val(Args)
+ else
+ begin
+ FnEnv := TEnv.Create(Fn.Env, Fn.Params, Args);
+ EVAL := EVAL(Fn.Ast, FnEnv);
+ end
+
+ end
+ else
+ raise Exception.Create('invalid apply');
+ 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;
+
+begin
+ Repl_Env := TEnv.Create;
+
+ // 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;
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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;
+ 'do':
+ begin
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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;
+
+begin
+ Repl_Env := TEnv.Create;
+
+ // 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;
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ math,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+ CmdArgs : TMalArray;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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;
+ 'do':
+ begin
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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));
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+ REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
+
+ if ParamCount >= 1 then
+ begin
+ REP('(load-file "' + ParamStr(1) + '")');
+ ExitCode := 0;
+ Exit;
+ end;
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ math,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+ CmdArgs : TMalArray;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+function is_pair(x: TMal) : Boolean;
+begin
+ is_pair := _sequential_Q(x) and (Length((x as TMalList).Val) > 0);
+end;
+
+function quasiquote(Ast: TMal) : TMal;
+var
+ Arr, Arr0 : TMalArray;
+ A0, A00 : TMal;
+begin
+ if not is_pair(Ast) then
+ Exit(_list(TMalSymbol.Create('quote'), Ast))
+ else
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ if (A0 is TMalSymbol) and
+ ((A0 as TMalSymbol).Val = 'unquote') then
+ Exit(Arr[1])
+ else if is_pair(A0) then
+ begin
+ Arr0 := (Arr[0] as TMalList).Val;
+ A00 := Arr0[0];
+ if (A00 is TMalSymbol) and
+ ((A00 as TMalSymbol).Val = 'splice-unquote') then
+ Exit(_list(TMalSymbol.Create('concat'),
+ Arr0[1],
+ quasiquote((Ast as TMalList).Rest)));
+ end;
+ quasiquote := _list(TMalSymbol.Create('cons'),
+ quasiquote(A0),
+ quasiquote((Ast as TMalList).Rest));
+ end;
+end;
+
+
+
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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]);
+ 'do':
+ begin
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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));
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+ REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
+
+ if ParamCount >= 1 then
+ begin
+ REP('(load-file "' + ParamStr(1) + '")');
+ ExitCode := 0;
+ Exit;
+ end;
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ math,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+ CmdArgs : TMalArray;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+function is_pair(x: TMal) : Boolean;
+begin
+ is_pair := _sequential_Q(x) and (Length((x as TMalList).Val) > 0);
+end;
+
+function quasiquote(Ast: TMal) : TMal;
+var
+ Arr, Arr0 : TMalArray;
+ A0, A00 : TMal;
+begin
+ if not is_pair(Ast) then
+ Exit(_list(TMalSymbol.Create('quote'), Ast))
+ else
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ if (A0 is TMalSymbol) and
+ ((A0 as TMalSymbol).Val = 'unquote') then
+ Exit(Arr[1])
+ else if is_pair(A0) then
+ begin
+ Arr0 := (Arr[0] as TMalList).Val;
+ A00 := Arr0[0];
+ if (A00 is TMalSymbol) and
+ ((A00 as TMalSymbol).Val = 'splice-unquote') then
+ Exit(_list(TMalSymbol.Create('concat'),
+ Arr0[1],
+ quasiquote((Ast as TMalList).Rest)));
+ end;
+ quasiquote := _list(TMalSymbol.Create('cons'),
+ quasiquote(A0),
+ quasiquote((Ast as TMalList).Rest));
+ end;
+end;
+
+function is_macro_call(Ast: TMal; Env: TEnv): Boolean;
+var
+ A0 : TMal;
+ Mac : TMal;
+begin
+ is_macro_call := false;
+ if (Ast.ClassType = TMalList) then
+ begin
+ A0 := (Ast as TMalList).Val[0];
+ if (A0 is TMalSymbol) and
+ (Env.Find(A0 as TMalSymbol) <> nil) then
+ begin
+ Mac := Env.Get((A0 as TMalSymbol));
+ if Mac is TMalFunc then
+ is_macro_call := (Mac as TMalFunc).isMacro;
+ end;
+ end;
+
+end;
+
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function macroexpand(Ast: TMal; Env: TEnv): TMal;
+var
+ A0 : TMal;
+ Arr : TMalArray;
+ Args : TMalArray;
+ Mac : TMalFunc;
+begin
+ while is_macro_call(Ast, Env) do
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc;
+ Args := (Ast as TMalList).Rest.Val;
+ if Mac.Ast = nil then
+ Ast := Mac.Val(Args)
+ else
+ Ast := EVAL(Mac.Ast,
+ TEnv.Create(Mac.Env, Mac.Params, Args));
+ end;
+ macroexpand := Ast;
+end;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ Ast := macroexpand(Ast, Env);
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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;
+ Fn.isMacro := true;
+ Exit(Env.Add((Arr[1] as TMalSymbol), Fn));
+ end;
+ 'macroexpand':
+ Exit(macroexpand(Arr[1], Env));
+ 'do':
+ begin
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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));
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+ REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
+ 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)))))))');
+ REP('(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))');
+
+
+ if ParamCount >= 1 then
+ begin
+ REP('(load-file "' + ParamStr(1) + '")');
+ ExitCode := 0;
+ Exit;
+ end;
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ math,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+ CmdArgs : TMalArray;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+function is_pair(x: TMal) : Boolean;
+begin
+ is_pair := _sequential_Q(x) and (Length((x as TMalList).Val) > 0);
+end;
+
+function quasiquote(Ast: TMal) : TMal;
+var
+ Arr, Arr0 : TMalArray;
+ A0, A00 : TMal;
+begin
+ if not is_pair(Ast) then
+ Exit(_list(TMalSymbol.Create('quote'), Ast))
+ else
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ if (A0 is TMalSymbol) and
+ ((A0 as TMalSymbol).Val = 'unquote') then
+ Exit(Arr[1])
+ else if is_pair(A0) then
+ begin
+ Arr0 := (Arr[0] as TMalList).Val;
+ A00 := Arr0[0];
+ if (A00 is TMalSymbol) and
+ ((A00 as TMalSymbol).Val = 'splice-unquote') then
+ Exit(_list(TMalSymbol.Create('concat'),
+ Arr0[1],
+ quasiquote((Ast as TMalList).Rest)));
+ end;
+ quasiquote := _list(TMalSymbol.Create('cons'),
+ quasiquote(A0),
+ quasiquote((Ast as TMalList).Rest));
+ end;
+end;
+
+function is_macro_call(Ast: TMal; Env: TEnv): Boolean;
+var
+ A0 : TMal;
+ Mac : TMal;
+begin
+ is_macro_call := false;
+ if (Ast.ClassType = TMalList) then
+ begin
+ A0 := (Ast as TMalList).Val[0];
+ if (A0 is TMalSymbol) and
+ (Env.Find(A0 as TMalSymbol) <> nil) then
+ begin
+ Mac := Env.Get((A0 as TMalSymbol));
+ if Mac is TMalFunc then
+ is_macro_call := (Mac as TMalFunc).isMacro;
+ end;
+ end;
+
+end;
+
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function macroexpand(Ast: TMal; Env: TEnv): TMal;
+var
+ A0 : TMal;
+ Arr : TMalArray;
+ Args : TMalArray;
+ Mac : TMalFunc;
+begin
+ while is_macro_call(Ast, Env) do
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc;
+ Args := (Ast as TMalList).Rest.Val;
+ if Mac.Ast = nil then
+ Ast := Mac.Val(Args)
+ else
+ Ast := EVAL(Mac.Ast,
+ TEnv.Create(Mac.Env, Mac.Params, Args));
+ end;
+ macroexpand := Ast;
+end;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ Ast := macroexpand(Ast, Env);
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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;
+ Fn.isMacro := true;
+ Exit(Env.Add((Arr[1] as TMalSymbol), Fn));
+ end;
+ 'macroexpand':
+ Exit(macroexpand(Arr[1], Env));
+ 'try*':
+ begin
+ try
+ Exit(EVAL(Arr[1], Env));
+ except
+ On E : Exception do
+ begin
+ 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
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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));
+
+ // core.mal: defined using language itself
+ REP('(def! not (fn* (a) (if a false true)))');
+ REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
+ 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)))))))');
+ REP('(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) `(let* (or_FIXME ~(first xs)) (if or_FIXME or_FIXME (or ~@(rest xs))))))))');
+
+
+ if ParamCount >= 1 then
+ begin
+ REP('(load-file "' + ParamStr(1) + '")');
+ ExitCode := 0;
+ Exit;
+ end;
+
+ while True do
+ begin
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
--- /dev/null
+program Mal;
+
+Uses sysutils,
+ CMem,
+ fgl,
+ math,
+ Readline in 'pas-readline/src/readline.pas',
+ History in 'pas-readline/src/history.pas',
+ mal_types,
+ mal_func,
+ reader,
+ printer,
+ mal_env,
+ core;
+
+var
+ Repl_Env : TEnv;
+ Line : PChar;
+ I : longint;
+ Key : string;
+ CmdArgs : TMalArray;
+
+// read
+function READ(const Str: string) : TMal;
+begin
+ READ := read_str(Str);
+end;
+
+// eval
+function is_pair(x: TMal) : Boolean;
+begin
+ is_pair := _sequential_Q(x) and (Length((x as TMalList).Val) > 0);
+end;
+
+function quasiquote(Ast: TMal) : TMal;
+var
+ Arr, Arr0 : TMalArray;
+ A0, A00 : TMal;
+begin
+ if not is_pair(Ast) then
+ Exit(_list(TMalSymbol.Create('quote'), Ast))
+ else
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ if (A0 is TMalSymbol) and
+ ((A0 as TMalSymbol).Val = 'unquote') then
+ Exit(Arr[1])
+ else if is_pair(A0) then
+ begin
+ Arr0 := (Arr[0] as TMalList).Val;
+ A00 := Arr0[0];
+ if (A00 is TMalSymbol) and
+ ((A00 as TMalSymbol).Val = 'splice-unquote') then
+ Exit(_list(TMalSymbol.Create('concat'),
+ Arr0[1],
+ quasiquote((Ast as TMalList).Rest)));
+ end;
+ quasiquote := _list(TMalSymbol.Create('cons'),
+ quasiquote(A0),
+ quasiquote((Ast as TMalList).Rest));
+ end;
+end;
+
+function is_macro_call(Ast: TMal; Env: TEnv): Boolean;
+var
+ A0 : TMal;
+ Mac : TMal;
+begin
+ is_macro_call := false;
+ if (Ast.ClassType = TMalList) then
+ begin
+ A0 := (Ast as TMalList).Val[0];
+ if (A0 is TMalSymbol) and
+ (Env.Find(A0 as TMalSymbol) <> nil) then
+ begin
+ Mac := Env.Get((A0 as TMalSymbol));
+ if Mac is TMalFunc then
+ is_macro_call := (Mac as TMalFunc).isMacro;
+ end;
+ end;
+
+end;
+
+// Forward declation since eval_ast call it
+function EVAL(Ast: TMal; Env: TEnv) : TMal; forward;
+
+function macroexpand(Ast: TMal; Env: TEnv): TMal;
+var
+ A0 : TMal;
+ Arr : TMalArray;
+ Args : TMalArray;
+ Mac : TMalFunc;
+begin
+ while is_macro_call(Ast, Env) do
+ begin
+ Arr := (Ast as TMalList).Val;
+ A0 := Arr[0];
+ Mac := Env.Get((A0 as TMalSymbol)) as TMalFunc;
+ Args := (Ast as TMalList).Rest.Val;
+ if Mac.Ast = nil then
+ Ast := Mac.Val(Args)
+ else
+ Ast := EVAL(Mac.Ast,
+ TEnv.Create(Mac.Env, Mac.Params, Args));
+ end;
+ macroexpand := Ast;
+end;
+
+function eval_ast(Ast: TMal; Env: TEnv) : TMal;
+var
+ OldArr, NewArr : TMalArray;
+ OldDict, NewDict : TMalDict;
+ I : longint;
+begin
+ if Ast is TMalSymbol then
+ begin
+ eval_ast := Env.Get((Ast as TMalSymbol));
+ end
+ else if Ast is TMalList then
+ begin
+ OldArr := (Ast as TMalList).Val;
+ SetLength(NewArr, Length(OldArr));
+ for I := 0 to Length(OldArr)-1 do
+ begin
+ NewArr[I] := EVAL(OldArr[I], Env);
+ end;
+ if Ast is TMalVector then
+ eval_ast := TMalVector.Create(NewArr)
+ else
+ eval_ast := TMalList.Create(NewArr);
+ end
+ else if Ast is TMalHashMap then
+ begin
+ OldDict := (Ast as TMalHashMap).Val;
+ NewDict := TMalDict.Create;
+ I := 0;
+ while I < OldDict.Count do
+ begin
+ NewDict[OldDict.Keys[I]] := EVAL(OldDict[OldDict.Keys[I]], Env);
+ I := I + 1;
+ end;
+ eval_ast := TMalHashMap.Create(NewDict);
+ end
+ else
+ eval_ast := Ast;
+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;
+begin
+ while true do
+ begin
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ Ast := macroexpand(Ast, Env);
+ if Ast.ClassType <> TMalList then
+ Exit(eval_ast(Ast, Env));
+
+ // Apply list
+ Lst := (Ast as TMalList);
+ Arr := Lst.Val;
+ 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;
+ Fn.isMacro := true;
+ Exit(Env.Add((Arr[1] as TMalSymbol), Fn));
+ end;
+ 'macroexpand':
+ Exit(macroexpand(Arr[1], Env));
+ 'try*':
+ begin
+ try
+ Exit(EVAL(Arr[1], Env));
+ except
+ On E : Exception do
+ begin
+ 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
+ eval_ast(TMalList.Create(copy(Arr,1, Length(Arr)-2)), Env);
+ 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
+ Arr := (eval_ast(Ast, Env) as TMalList).Val;
+ if Arr[0] is TMalFunc then
+ begin
+ Fn := Arr[0] as TMalFunc;
+ if Length(Arr) < 2 then
+ SetLength(Args, 0)
+ else
+ Args := copy(Arr, 1, Length(Arr)-1);
+ 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)))');
+ REP('(def! load-file (fn* (f) (eval (read-string (str "(do " (slurp f) ")")))))');
+ 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)))))))');
+ REP('(def! *gensym-counter* (atom 0))');
+ REP('(def! gensym (fn* () (symbol (str "G__" (swap! *gensym-counter* (fn* [x] (+ 1 x)))))))');
+ REP('(defmacro! or (fn* (& xs) (if (empty? xs) nil (if (= 1 (count xs)) (first xs) (let* (condvar (gensym)) `(let* (~condvar ~(first xs)) (if ~condvar ~condvar (or ~@(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
+ Line := Readline.readline('user> ');
+ if Line = Nil then
+ Halt(0);
+ if Line[0] = #0 then
+ continue;
+ add_history(Line);
+
+ try
+ WriteLn(REP(Line))
+ except
+ On E : Exception do
+ begin
+ WriteLn('Error: ' + E.message);
+ WriteLn('Backtrace:');
+ WriteLn(GetBacktrace(E));
+ end;
+ end;
+ end;
+end.
(pr-str (list 1 2 "abc" "\"") "def")
;=>"(1 2 \"abc\" \"\\\"\") \"def\""
-(pr-str [1 2 "abc" "\""] "def")
-;=>"[1 2 \"abc\" \"\\\"\"] \"def\""
-
(pr-str "abc\ndef\nghi")
;=>"\"abc\\ndef\\nghi\""
(pr-str (list))
;=>"()"
-(pr-str [])
-;=>"[]"
-
;; Testing str
(str)
(str (list 1 2 "abc" "\"") "def")
;=>"(1 2 abc \")def"
-(str [1 2 "abc" "\""] "def")
-;=>"[1 2 abc \"]def"
-
(str (list))
;=>"()"
-(str [])
-;=>"[]"
-
;; Testing prn
(prn)
;
(if [] 7 8)
;=>7
+;; Testing vector printing
+(pr-str [1 2 "abc" "\""] "def")
+;=>"[1 2 \"abc\" \"\\\"\"] \"def\""
+
+(pr-str [])
+;=>"[]"
+
+(str [1 2 "abc" "\""] "def")
+;=>"[1 2 abc \"]def"
+
+(str [])
+;=>"[]"
+
+
;; Testing vector functions
(count [1 2 3])
;=>3
;; Testing swap!/closure interaction
(def! inc-it (fn* (a) (+ 1 a)))
(def! atm (atom 7))
-(def! f (fn* [] (swap! atm inc-it)))
+(def! f (fn* () (swap! atm inc-it)))
(f)
;=>8
(f)
;=>9
+;;
;; -------- Optional Functionality --------
;; Testing comments in a file
;=>9
(apply prn (list 1 2 "3" (list)))
; 1 2 "3" ()
+;=>nil
(apply prn 1 2 (list "3" (list)))
; 1 2 "3" ()
+;=>nil
;; Testing apply function with user functions
(apply (fn* (a b) (+ a b)) (list 2 3))
HCoop / jackhill / mal.git / commitdiff