--- /dev/null
+/*******************************************************************\r
+ *\r
+ * A Lisp interpreter, written in Prolog\r
+ *\r
+ * (lisp_interpreter.pl)\r
+ *\r
+ * (c) Neil Smith, 2001\r
+ *\r
+ * This program is a small interpreter for Lisp. It was written\r
+ * in LPA Prolog v3.6, running under Windows. It should be fairly\r
+ * easy to convert it to other Prologs.\r
+ *\r
+ * It supports real Lisp syntax, excessive brackets and all. You don't \r
+ * need to terminate input with a full stop. It also understands \r
+ * 'x for (quote x) and #'func for (function func)\r
+ *\r
+ * Variables are lexically scoped, except where defined as special.\r
+ *\r
+ * read_words code from "The Craft of Prolog", R.A.O'Keefe\r
+ * lisp evaluator from "Lisp" (3rd ed), Winston & Horn.\r
+ *\r
+ *******************************************************************/\r
+\r
+\r
+:- style_check.\r
+\r
+:- dynamic \r
+ bindings/1,\r
+ lambda/2.\r
+\r
+% :- initialization lisp.\r
+\r
+\r
+bindings([]).\r
+\r
+\r
+lisp:-\r
+ write('Welcome to Pro-Lisp!'),nl,\r
+ write('This is a miniscule Lisp interpreter, written in Prolog'),nl,\r
+ prompt(Old, '> '),\r
+ prompts(Old1, Old2),\r
+ prompts('> ', '> '),\r
+ tidy_database,\r
+ repeat,\r
+ read_eval_print(Result),\r
+ Result = quit,\r
+ prompt(_, Old),\r
+ prompts(Old1, Old2).\r
+\r
+\r
+tidy_database:-\r
+ retract(bindings(_)),\r
+ assert(bindings([])),\r
+ retractall(lambda(_, _)).\r
+\r
+\r
+read_eval_print(Result):- % dodgy use of cuts to force a single evaluation\r
+ read_and_parse(Expression),\r
+ eval(Expression, Result),\r
+ writeExpression(Result),\r
+ !.\r
+\r
+\r
+\r
+% basic EVAL statements for built-in procedures\r
+\r
+eval(Expression, Result):-\r
+ bindings(Bindings),\r
+ eval(Expression, Bindings, Result).\r
+\r
+\r
+macro_expand([],[]):-!.\r
+macro_expand([#, '''', X|Xs], [[function, MX]|MXs]):-\r
+ !,\r
+ macro_expand(X, MX),\r
+ macro_expand(Xs, MXs).\r
+macro_expand(['''', X|Xs], [[quote, MX]|MXs]):-\r
+ !,\r
+ macro_expand(X, MX),\r
+ macro_expand(Xs, MXs).\r
+macro_expand([X|Xs], [MX|MXs]):-\r
+ !,\r
+ macro_expand(X, MX),\r
+ macro_expand(Xs, MXs).\r
+macro_expand(X, X):-\r
+ atomic(X),\r
+ !.\r
+\r
+\r
+eval(quit, _, quit):-!.\r
+eval(nil, _, []):-!.\r
+eval(t, _, t):-!.\r
+eval([], _, []):-!.\r
+eval([quote, X], _, X):-!.\r
+eval([quit], _, quit):-!.\r
+eval([defvar, Name], _, Name):-\r
+ !,\r
+ retract(bindings(GlobalBindings)),\r
+ assert(bindings([binding(Name, [])|GlobalBindings])),\r
+ !.\r
+eval([setq, Name, Value], Bindings, EvalValue):-\r
+ !,\r
+ bindings(GlobalBindings),\r
+ append(Pre, [binding(Name, _)|Post], GlobalBindings),\r
+ eval(Value, Bindings, EvalValue),\r
+ retract(bindings(GlobalBindings)),\r
+ append(Pre, [binding(Name, EvalValue)|Post], GlobalBindings1),\r
+ assert(bindings(GlobalBindings1)),\r
+ !.\r
+eval([defun, Name, FormalParms, Body], _, Name):-\r
+ !,\r
+ assert(lambda(Name, [lambda, FormalParms, Body])),\r
+ !.\r
+eval([apply|Arguments], Bindings, Result):-\r
+ !,\r
+ evalL(Arguments, Bindings, [Function, ActualParams]),\r
+ apply(Function, ActualParams, Result),\r
+ !.\r
+eval([function, [lambda, FormalParams, Body]], Bindings, \r
+ [closure, FormalParams, Body, Bindings]):-!.\r
+eval([Procedure|Arguments], Bindings, Result):-\r
+ evalL(Arguments, Bindings, EvalArguments),\r
+ apply(Procedure, EvalArguments, Result),\r
+ !.\r
+eval(X, _, X):-\r
+ number(X), \r
+ !.\r
+eval(X, Bindings, Val):-\r
+ atom(X),\r
+ member(binding(X, Val), Bindings)\r
+ ; (bindings(GlobalBindings),\r
+ member(binding(X, Val), GlobalBindings)),\r
+ !.\r
+eval(X, _, []):-\r
+ write('ERROR! Cannot find a binding for `'),\r
+ write(X),\r
+ write('`'),nl,\r
+ !.\r
+\r
+\r
+evalL([], _, []):-!.\r
+evalL([H|T], Bindings, [EvalH|EvalT]):-\r
+ eval(H, Bindings, EvalH),\r
+ evalL(T, Bindings, EvalT),\r
+ !.\r
+\r
+\r
+apply(car, [[Result|_]], Result):-!.\r
+apply(cdr, [[_|Result]], Result):-!.\r
+apply(list, Args, Args):-!.\r
+apply(cons, [Arg1, Arg2], [Arg1|Arg2]):-!.\r
+apply(eq, [Arg1, Arg2], Result):-\r
+ (Arg1 = Arg2 -> Result = Arg1 \r
+ ; Result = []),\r
+ !.\r
+apply(if, [Test, Success, Failure], Result):-\r
+ eval(Test, TestResult),\r
+ eval(Success, EvalSuccess),\r
+ eval(Failure, EvalFailure),\r
+ (TestResult = [] -> Result = EvalFailure\r
+ ; Result = EvalSuccess),\r
+ !.\r
+apply([lambda, FormalParams, Body], ActualParams, Result):-\r
+ !,\r
+ bind_variables(FormalParams, ActualParams, Bindings),\r
+ eval(Body, Bindings, Result),\r
+ !.\r
+apply([closure, FormalParams, Body, Bindings0], ActualParams, Result):-\r
+ !,\r
+ bind_variables(FormalParams, ActualParams, Bindings0, Bindings),\r
+ eval(Body, Bindings, Result),\r
+ !.\r
+apply(ProcedureName, Args, Result):-\r
+ lambda(ProcedureName, LambdaExpression),\r
+ apply(LambdaExpression, Args, Result),\r
+ !.\r
+apply(X, _, []):-\r
+ write('ERROR! Cannot find a procedure description for `'),\r
+ write(X),\r
+ write('`'),nl,\r
+ !.\r
+ \r
+\r
+\r
+bind_variables(Formal, Actual, Bindings):-\r
+ bind_variables(Formal, Actual, [], Bindings).\r
+\r
+bind_variables([], [], Bindings, Bindings).\r
+bind_variables([FormalParam|FormalParams], [ActualParam|ActualParams],\r
+ Bindings0, Bindings):- \r
+ bind_variables(FormalParams, ActualParams, \r
+ [binding(FormalParam, ActualParam)|Bindings0], Bindings).\r
+\r
+\r
+\r
+\r
+% read and parse a line of Lisp\r
+\r
+read_and_parse(Expression):-\r
+ read_words(TokenL),\r
+ ( sexpr(Expression, TokenL, [])\r
+ ;\r
+ ( write('ERROR! Could not parse `'),\r
+ writeTokenL(TokenL),\r
+ write('`'),nl,\r
+ Expression = [] )\r
+ ),\r
+ !.\r
+\r
+\r
+\r
+% read a line of supposed Lisp code\r
+\r
+read_words(Words):-\r
+ get0(C),\r
+ read_words(C, Words).\r
+\r
+read_words(C, []):-\r
+ ends_line(C), \r
+ !.\r
+read_words(C, Words):-\r
+ whitespace(C),\r
+ !,\r
+ read_words(Words).\r
+read_words(C, [Word|Words]):-\r
+ punctuation(C),\r
+ !,\r
+ name(Word, [C]),\r
+ read_words(Words).\r
+read_words(C, [Word|Words]):-\r
+ other(C),\r
+ !,\r
+ read_rest_of_word(Chars, LeftOver),\r
+ name(UCWord, [C|Chars]),\r
+ ( atom(UCWord) -> lwrupr(Word, UCWord)\r
+ ; \r
+ Word = UCWord),\r
+ read_words(LeftOver, Words).\r
+\r
+\r
+read_rest_of_word(Chars, LeftOver):-\r
+ get0(C),\r
+ read_rest_of_word(C, Chars, LeftOver).\r
+\r
+\r
+read_rest_of_word(C, [], C):-\r
+ \+ other(C),\r
+ !.\r
+read_rest_of_word(C, [C|Chars], LeftOver):-\r
+ other(C),\r
+ !,\r
+ read_rest_of_word(Chars, LeftOver).\r
+\r
+\r
+\r
+ends_line(10).\r
+ends_line(13).\r
+\r
+\r
+whitespace(9).\r
+whitespace(32).\r
+\r
+\r
+punctuation(0'.).\r
+punctuation(0'!).\r
+punctuation(0'").\r
+punctuation(0',).\r
+punctuation(0'').\r
+punctuation(0':).\r
+punctuation(0';).\r
+punctuation(0'?).\r
+punctuation(0'().\r
+punctuation(0')).\r
+punctuation(0'[).\r
+punctuation(0']).\r
+% punctuation(0'#).\r
+\r
+\r
+other(Char):-\r
+ integer(Char),\r
+ Char >= 0,\r
+ Char =< 127,\r
+ \+ ends_line(Char),\r
+ \+ whitespace(Char),\r
+ \+ punctuation(Char).\r
+\r
+\r
+% Grammar rules for parsing Lisp s-expressions.\r
+% Given a list of tokens, lisplist does all the nesting of lists\r
+\r
+\r
+sexpr([function, Expression]) --> [#, ''''], !, sexpr(Expression).\r
+sexpr([quote, Expression]) --> [''''], !, sexpr(Expression).\r
+sexpr(Xs) --> ['('], lisplist(Xs), !.\r
+sexpr(X) --> [X], {atomic(X), X \= '.'}, !.\r
+\r
+\r
+lisplist([]) --> [')'], !.\r
+lisplist([X|Xs]) --> sexpr(X), lisplist(Xs), !.\r
+lisplist([X|Y]) --> sexpr(X), ['.'], sexpr(Y), [')'], !.\r
+\r
+\r
+\r
+% writeExpression/1 displays a lisp expression\r
+\r
+writeExpression(quit):-\r
+ !,\r
+ write('Terminating Pro-Lisp'),nl.\r
+writeExpression(Expression):-\r
+ sexpr(Expression, TokenL, []),\r
+% write(' '),\r
+ writeTokenL(TokenL),\r
+ nl.\r
+\r
+\r
+writeTokenL([]).\r
+writeTokenL(['(', ')'|TokenL]):-\r
+ !,\r
+ write('NIL '),\r
+ writeTokenL(TokenL).\r
+writeTokenL([Token|TokenL]):-\r
+ atom(Token),\r
+ !,\r
+ lwrupr(Token, UCToken),\r
+ write(UCToken),\r
+ write(' '),\r
+ writeTokenL(TokenL).\r
+writeTokenL([Token|TokenL]):-\r
+ number(Token),\r
+ !,\r
+ write(Token),\r
+ write(' '),\r
+ writeTokenL(TokenL).\r