lisp-interpreter.pl

   1 /*******************************************************************
   2  *
   3  * A Lisp interpreter, written in Prolog
   4  *
   5  * (lisp_interpreter.pl)
   6  *
   7  * (c) Neil Smith, 2001
   8  *
   9  * This program is a small interpreter for Lisp.  It was written
  10  * in LPA Prolog v3.6, running under Windows.  It should be fairly
  11  * easy to convert it to other Prologs.
  12  *
  13  * It supports real Lisp syntax, excessive brackets and all.  You don't
  14  * need to terminate input with a full stop.  It also understands
  15  * 'x for (quote x) and #'func for (function func)
  16  *
  17  * Variables are lexically scoped, except where defined as special.
  18  *
  19  * read_words code from "The Craft of Prolog", R.A.O'Keefe
  20  * lisp evaluator from "Lisp" (3rd ed), Winston & Horn.
  21  *
  22  *******************************************************************/
  23
  24
  25 :- style_check.
  26
  27 :- dynamic
  28         bindings/1,
  29         lambda/2.
  30
  31 % :- initialization lisp.
  32
  33
  34 bindings([]).
  35
  36
  37 lisp:-
  38         write('Welcome to Pro-Lisp!'),nl,
  39         write('This is a miniscule Lisp interpreter, written in Prolog'),nl,
  40         prompt(Old, '> '),
  41         prompts(Old1, Old2),
  42         prompts('> ', '> '),
  43         tidy_database,
  44         repeat,
  45         read_eval_print(Result),
  46         Result = quit,
  47         prompt(_, Old),
  48         prompts(Old1, Old2).
  49
  50
  51 tidy_database:-
  52         retract(bindings(_)),
  53         assert(bindings([])),
  54         retractall(lambda(_, _)).
  55
  56
  57 read_eval_print(Result):-               % dodgy use of cuts to force a single evaluation
  58         read_and_parse(Expression),
  59         eval(Expression, Result),
  60         writeExpression(Result),
  61         !.
  62
  63
  64
  65 % basic EVAL statements for built-in procedures
  66
  67 eval(Expression, Result):-
  68         bindings(Bindings),
  69         eval(Expression, Bindings, Result).
  70
  71
  72 macro_expand([],[]):-!.
  73 macro_expand([#, '''', X|Xs], [[function, MX]|MXs]):-
  74         !,
  75         macro_expand(X, MX),
  76         macro_expand(Xs, MXs).
  77 macro_expand(['''', X|Xs], [[quote, MX]|MXs]):-
  78         !,
  79         macro_expand(X, MX),
  80         macro_expand(Xs, MXs).
  81 macro_expand([X|Xs], [MX|MXs]):-
  82         !,
  83         macro_expand(X, MX),
  84         macro_expand(Xs, MXs).
  85 macro_expand(X, X):-
  86         atomic(X),
  87         !.
  88
  89
  90 eval(quit, _, quit):-!.
  91 eval(nil, _, []):-!.
  92 eval(t, _, t):-!.
  93 eval([], _, []):-!.
  94 eval([quote, X], _, X):-!.
  95 eval([quit], _, quit):-!.
  96 eval([defvar, Name], _, Name):-
  97         !,
  98         retract(bindings(GlobalBindings)),
  99         assert(bindings([binding(Name, [])|GlobalBindings])),
 100         !.
 101 eval([setq, Name, Value], Bindings, EvalValue):-
 102         !,
 103         bindings(GlobalBindings),
 104         append(Pre, [binding(Name, _)|Post], GlobalBindings),
 105         eval(Value, Bindings, EvalValue),
 106         retract(bindings(GlobalBindings)),
 107         append(Pre, [binding(Name, EvalValue)|Post], GlobalBindings1),
 108         assert(bindings(GlobalBindings1)),
 109         !.
 110 eval([defun, Name, FormalParms, Body], _, Name):-
 111         !,
 112         assert(lambda(Name, [lambda, FormalParms, Body])),
 113         !.
 114 eval([apply|Arguments], Bindings, Result):-
 115         !,
 116         evalL(Arguments, Bindings, [Function, ActualParams]),
 117         apply(Function, ActualParams, Result),
 118         !.
 119 eval([function, [lambda,  FormalParams, Body]], Bindings,
 120                 [closure, FormalParams, Body, Bindings]):-!.
 121 eval([Procedure|Arguments], Bindings, Result):-
 122         evalL(Arguments, Bindings, EvalArguments),
 123         apply(Procedure, EvalArguments, Result),
 124         !.
 125 eval(X, _, X):-
 126         number(X),
 127         !.
 128 eval(X, Bindings, Val):-
 129         atom(X),
 130                 member(binding(X, Val), Bindings)
 131         ;       (bindings(GlobalBindings),
 132                  member(binding(X, Val), GlobalBindings)),
 133         !.
 134 eval(X, _, []):-
 135         write('ERROR!  Cannot find a binding for `'),
 136         write(X),
 137         write('`'),nl,
 138         !.
 139
 140
 141 evalL([], _, []):-!.
 142 evalL([H|T], Bindings, [EvalH|EvalT]):-
 143         eval(H, Bindings, EvalH),
 144         evalL(T, Bindings, EvalT),
 145         !.
 146
 147
 148 apply(car, [[Result|_]], Result):-!.
 149 apply(cdr, [[_|Result]], Result):-!.
 150 apply(list, Args, Args):-!.
 151 apply(cons, [Arg1, Arg2], [Arg1|Arg2]):-!.
 152 apply(eq, [Arg1, Arg2], Result):-
 153         (Arg1 = Arg2 -> Result = Arg1
 154                       ; Result = []),
 155         !.
 156 apply(if, [Test, Success, Failure], Result):-
 157         eval(Test, TestResult),
 158         eval(Success, EvalSuccess),
 159         eval(Failure, EvalFailure),
 160         (TestResult = [] -> Result = EvalFailure
 161                           ; Result = EvalSuccess),
 162         !.
 163 apply([lambda, FormalParams, Body], ActualParams, Result):-
 164         !,
 165         bind_variables(FormalParams, ActualParams, Bindings),
 166         eval(Body, Bindings, Result),
 167         !.
 168 apply([closure, FormalParams, Body, Bindings0], ActualParams, Result):-
 169         !,
 170         bind_variables(FormalParams, ActualParams, Bindings0, Bindings),
 171         eval(Body, Bindings, Result),
 172         !.
 173 apply(ProcedureName, Args, Result):-
 174         lambda(ProcedureName, LambdaExpression),
 175         apply(LambdaExpression, Args, Result),
 176         !.
 177 apply(X, _, []):-
 178         write('ERROR!  Cannot find a procedure description for `'),
 179         write(X),
 180         write('`'),nl,
 181         !.
 182
 183
 184
 185 bind_variables(Formal, Actual, Bindings):-
 186         bind_variables(Formal, Actual, [], Bindings).
 187
 188 bind_variables([], [], Bindings, Bindings).
 189 bind_variables([FormalParam|FormalParams], [ActualParam|ActualParams],
 190                 Bindings0, Bindings):-
 191         bind_variables(FormalParams, ActualParams,
 192                 [binding(FormalParam, ActualParam)|Bindings0], Bindings).
 193
 194
 195
 196
 197 % read and parse a line of Lisp
 198
 199 read_and_parse(Expression):-
 200         read_words(TokenL),
 201         (       sexpr(Expression, TokenL, [])
 202         ;
 203                 ( write('ERROR!  Could not parse `'),
 204                   writeTokenL(TokenL),
 205                   write('`'),nl,
 206                   Expression = [] )
 207         ),
 208         !.
 209
 210
 211
 212 % read a line of supposed Lisp code
 213
 214 read_words(Words):-
 215         get0(C),
 216         read_words(C, Words).
 217
 218 read_words(C, []):-
 219         ends_line(C),
 220         !.
 221 read_words(C, Words):-
 222         whitespace(C),
 223         !,
 224         read_words(Words).
 225 read_words(C, [Word|Words]):-
 226         punctuation(C),
 227         !,
 228         name(Word, [C]),
 229         read_words(Words).
 230 read_words(C, [Word|Words]):-
 231         other(C),
 232         !,
 233         read_rest_of_word(Chars, LeftOver),
 234         name(UCWord, [C|Chars]),
 235         ( atom(UCWord) -> lwrupr(Word, UCWord)
 236                 ;
 237                 Word = UCWord),
 238         read_words(LeftOver, Words).
 239
 240
 241 read_rest_of_word(Chars, LeftOver):-
 242         get0(C),
 243         read_rest_of_word(C, Chars, LeftOver).
 244
 245
 246 read_rest_of_word(C, [], C):-
 247         \+ other(C),
 248         !.
 249 read_rest_of_word(C, [C|Chars], LeftOver):-
 250         other(C),
 251         !,
 252         read_rest_of_word(Chars, LeftOver).
 253
 254
 255
 256 ends_line(10).
 257 ends_line(13).
 258
 259
 260 whitespace(9).
 261 whitespace(32).
 262
 263
 264 punctuation(0'.).
 265 punctuation(0'!).
 266 punctuation(0'").
 267 punctuation(0',).
 268 punctuation(0'').
 269 punctuation(0':).
 270 punctuation(0';).
 271 punctuation(0'?).
 272 punctuation(0'().
 273 punctuation(0')).
 274 punctuation(0'[).
 275 punctuation(0']).
 276 % punctuation(0'#).
 277
 278
 279 other(Char):-
 280         integer(Char),
 281         Char >= 0,
 282         Char =< 127,
 283         \+ ends_line(Char),
 284         \+ whitespace(Char),
 285         \+ punctuation(Char).
 286
 287
 288 % Grammar rules for parsing Lisp s-expressions.
 289 % Given a list of tokens, lisplist does all the nesting of lists
 290
 291
 292 sexpr([function, Expression]) --> [#, ''''], !, sexpr(Expression).
 293 sexpr([quote, Expression]) --> [''''], !, sexpr(Expression).
 294 sexpr(Xs) --> ['('], lisplist(Xs), !.
 295 sexpr(X) --> [X], {atomic(X), X \= '.'}, !.
 296
 297
 298 lisplist([]) --> [')'], !.
 299 lisplist([X|Xs]) --> sexpr(X), lisplist(Xs), !.
 300 lisplist([X|Y]) --> sexpr(X), ['.'], sexpr(Y), [')'], !.
 301
 302
 303
 304 % writeExpression/1 displays a lisp expression
 305
 306 writeExpression(quit):-
 307         !,
 308         write('Terminating Pro-Lisp'),nl.
 309 writeExpression(Expression):-
 310         sexpr(Expression, TokenL, []),
 311 %       write('  '),
 312         writeTokenL(TokenL),
 313         nl.
 314
 315
 316 writeTokenL([]).
 317 writeTokenL(['(', ')'|TokenL]):-
 318         !,
 319         write('NIL '),
 320         writeTokenL(TokenL).
 321 writeTokenL([Token|TokenL]):-
 322         atom(Token),
 323         !,
 324         lwrupr(Token, UCToken),
 325         write(UCToken),
 326         write(' '),
 327         writeTokenL(TokenL).
 328 writeTokenL([Token|TokenL]):-
 329         number(Token),
 330         !,
 331         write(Token),
 332         write(' '),
 333         writeTokenL(TokenL).