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