lisp_compiler.pl

   1 /*******************************************************************
   2  *
   3  * A Lisp compiler, written in Prolog
   4  *
   5  * (lisp_compiler.pl)
   6  *
   7  * (c) Neil Smith, 2001
   8  *
   9  * This program, and its associated support files, forms a compiler
  10  * for a subset of the language LISP.  It supports a few simple
  11  * built-in procedures, listed below.  It also supports both special
  12  * and lexical variables, and higher-order functions and lexical
  13  * closures.
  14  *
  15  * This compiler was written in LPA Prolog v3.6 under MS Windows.
  16  * It should run under other Prologs without too much conversion needed,
  17  * but note the required library modules.
  18  *
  19  *
  20  * Special forms
  21  *
  22  * [] and nil are treated as special forms, evaluating to [], and treated as 'false'
  23  * t is a special form, evaluating to t, and treated as 'true'
  24  * if, cond
  25  * progn (and implicit progn in defun and let bodies)
  26  * quote
  27  * let
  28  * setq
  29  * function
  30  * lambda
  31  * defvar, defparameter (both with and without initial values)
  32  *
  33  * Built-in procedures (defined in builtin_lisp_functions.pl)
  34  *
  35  * cons, first, rest, null
  36  * eq, equalp
  37  * plus, minus, times, divide
  38  * lisp_not, or, and
  39  * lisp_apply
  40  *
  41  * Other procedures are defined in lisp_library.pl
  42  *
  43  *******************************************************************/
  44
  45 /*******************************************************************
  46  *
  47  * Example definitions:
  48  * second(l) <<== first(rest(l)).
  49  * list_3(a, b, c) <<== cons(a, cons(b, cons(c, nil))).
  50  *
  51  * Example use:
  52  * ?| - lisp_call(second([a,b,c]), Result).
  53  * Result = b
  54  *
  55  * ?| - second([a,b,c], Result).
  56  * Result = b
  57  *
  58  * ?| - lisp_call(list_3(tom, dick, harry), Result).
  59  * Result = [tom, dick, harry]
  60  *
  61  * ?| - list_3(tom, dick, harry, Result).
  62  * Result = [tom, dick, harry]
  63  *
  64  *******************************************************************/
  65
  66 :- style_check([+singleton, +no_effect, +var_branches, +atom, +discontiguous,
  67         +charset]).
  68
  69 :- use_module(library(apply)).
  70
  71 % :- ensure_loaded(library(higher_order)).
  72 % :- ensure_loaded(library(list_utilities)).
  73
  74
  75 % :- ensure_loaded(builtin_lisp_functions). % Lisp primitives: this directives is at the end of the file
  76 % :- ensure_loaded(lisp_library).       % Functions defined in lisp: this directive is at the end of the file
  77                                         % allowing them to be compiled correctly
  78
  79
  80 :- op(1200, xfx, <<== ).        % function definition
  81 :- op(1200,  fx, <<== ).        % functional imperative definition
  82
  83 :- dynamic special_var/2.       % closure environments
  84
  85
  86 % Connection to LPA's built-in error handler
  87
  88 /*
  89 '?ERROR?'(Error, Form):-
  90         lisp_error_description(_, Error, Description),
  91         !,
  92         write('LISP ERROR  '),
  93         write(Description),
  94         write(Form),
  95         nl.
  96 '?ERROR?'(Error, Goal):-
  97         error_hook(Error, Goal).
  98 */
  99
 100 lisp_error_description(unbound_atom,        'No value found for atom: ').
 101 lisp_error_description(atom_does_not_exist, 'Setq: Variable does not exist: ').
 102 lisp_error_description(first_not_cons,      'First: This is not a cons cell: ').
 103 lisp_error_description(rest_not_cons,       'Rest: This is not a cons cell: ').
 104
 105
 106 make_binding(Arg, Val, binding(Arg, [Val|_])).
 107 make_environment(Variable, Form, bind(Variable, Form)).
 108
 109
 110 % The hook into the compiler
 111
 112 term_expansion( (FunctionHead <<== FunctionBody),
 113                 (Head         :-   Body) ):-
 114         expand_function_head(FunctionHead, Head, ArgBindings, Result),
 115         expand_function_body(implicit_progn(FunctionBody), Result, Body, [ArgBindings]).
 116
 117 term_expansion( ( <<== FunctionBody),
 118                 ( :-   Body) ):-
 119         expand_function_body(implicit_progn(FunctionBody), _Result, Body, []).
 120
 121
 122 expand_function_head(FunctionHead, Head, ArgBindings, Result):-
 123         FunctionHead =.. [FunctionName | FormalArgs],
 124         % compound_name_arguments(FunctionHead, FunctionName, FormalArgs),
 125         % zip_with(FormalArgs, ActualArgs, [Arg, Val, binding(Arg, [Val|_])]^true, ArgBindings),
 126         maplist(make_binding, FormalArgs, ActualArgs, ArgBindings),
 127         append(ActualArgs, [Result], HeadArgs),
 128         Head =.. [FunctionName | HeadArgs].
 129         % compound_name_arguments(Head, FunctionName, HeadArgs).
 130
 131
 132 % expand_function_body(Function, Result, Body, Environment).
 133 % Expands a Lisp-like function body into its Prolog equivalent
 134 expand_function_body(nil, [], true, _Environment):-
 135         !.
 136 expand_function_body([], [], true, _Environment):-
 137         !.
 138 expand_function_body(t,   t,  true, _Environment):-
 139         !.
 140 expand_function_body(if(Test, IfTrue, IfFalse), Result, Body, Environment):-
 141         !,
 142         expand_function_body(Test,    TestResult,  TestBody,  Environment),
 143         expand_function_body(IfTrue,  TrueResult,  TrueBody,  Environment),
 144         expand_function_body(IfFalse, FalseResult, FalseBody, Environment),
 145         Body = (        TestBody,
 146                         ( TestResult \= []
 147                                 ->      TrueBody,
 148                                         Result      = TrueResult
 149                                 ;       FalseBody,
 150                                         Result      = FalseResult       ) ).
 151
 152 expand_function_body(cond([]), [], true, _Environment):-
 153         !.
 154 expand_function_body(cond([ [Test|ResultForms] |Clauses]), Result, Body, Environment):-
 155         !,
 156         expand_function_body(Test, TestResult, TestBody, Environment),
 157         expand_progn(ResultForms, TestResult, ResultFormsResult, ResultFormsBody, Environment),
 158         expand_function_body(cond(Clauses), ClausesResult, ClausesBody, Environment),
 159         Body = (        TestBody,
 160                         ( TestResult \= []
 161                                 ->      ResultFormsBody,
 162                                         Result      = ResultFormsResult
 163                                 ;       ClausesBody,
 164                                         Result      = ClausesResult )   ).
 165
 166 expand_function_body(progn(Forms), Result, Body, Environment):-
 167         !,
 168         expand_progn(Forms, [], Result, Body, Environment).
 169
 170 expand_function_body(implicit_progn(Forms), Result, Body, Environment):-
 171         !,
 172         % (once (Forms = [] ; Forms = [_|_] )
 173         is_list(Forms)
 174         ->  expand_progn(Forms, [], Result, Body, Environment)
 175         ;   expand_function_body(Forms, Result, Body, Environment).
 176
 177
 178 expand_function_body(setq(Atom, ValueForm), Result, Body, Environment):-
 179         !,
 180         lisp_error_description(atom_does_not_exist, ErrMsg),
 181         expand_function_body(ValueForm, Result, ValueBody, Environment),
 182         Body = (        ValueBody,
 183                         (       member(Bindings, Environment),
 184                                 member(binding(Atom, Value0), Bindings)
 185                         ->      extract_variable_value(Value0, _, Hole),
 186                                 Hole = [Result|_]
 187                         ;       special_var(Atom, Old)
 188                         ->      once(retract(special_var(Atom, Old))),
 189                                 assert(special_var(Atom, Result))
 190                         ;       throw(error(atom_does_not_exist(Atom), context(setq, ErrMsg)))  )       ).
 191
 192 expand_function_body(quote(Item), Item, true, _Environment):-
 193         !.
 194
 195 expand_function_body(let(NewBindings, BodyForms), Result, Body, Environment):-
 196         !,
 197         % zip_with(Variables, ValueForms, [Variable, Form, bind(Variable, Form)]^true, NewBindings),
 198         maplist(make_environment, Variables, ValueForms, NewBindings),
 199         expand_arguments(ValueForms, ValueBody, Values, Environment),
 200         % zip_with(Variables, Values, [Var, Val, binding(Var, [Val|_])]^true, Bindings),
 201         maplist(make_binding, Variables, Values, Bindings),
 202         Body = ( ValueBody, BodyFormsBody ),
 203         expand_function_body(implicit_progn(BodyForms), Result, BodyFormsBody,
 204                 [Bindings|Environment]).
 205
 206 expand_function_body(function(lambda(LambdaArgs, LambdaBody)), Result, Body, Environment):-
 207         !,
 208         expand_function_body(implicit_progn(LambdaBody), ClosureResult, ClosureBody, ClosureEnvironment),
 209         Result = closure(LambdaArgs,
 210                         [ClosureEnvironment, ClosureResult]^ClosureBody,
 211                         Environment),
 212         Body = true.
 213
 214 expand_function_body(function(Function), function(Function), true, _Environment):-
 215         !.
 216
 217 expand_function_body(defvar(Var), Result, Body, Environment):-
 218         !,
 219         expand_function_body(defvar(Var, nil), Result, Body, Environment).
 220 expand_function_body(defvar(Var, Value), Result, Body, Environment):-
 221         !,
 222         expand_function_body(Value, Result, ValueBody, Environment),
 223         Body = (        ValueBody,
 224                         (       special_var(Var, _)
 225                         ->      true
 226                         ;       assert(special_var(Var, Result))        )       ).
 227 expand_function_body(defparameter(Var), Result, Body, Environment):-
 228         !,
 229         expand_function_body(defparameter(Var, nil), Result, Body, Environment).
 230 expand_function_body(defparameter(Var, Value), Result, Body, Environment):-
 231         !,
 232         expand_function_body(Value, Result, ValueBody, Environment),
 233         Body = (        ValueBody,
 234                         (       special_var(Var, _)
 235                         ->      one(retract(special_var(Var, _)))
 236                         ;       true    ),
 237                         assert(special_var(Var, Result))        ).
 238
 239 expand_function_body(Number, Number, true, _Environment):-
 240         number(Number),
 241         !.
 242
 243 expand_function_body(Atom, Value, Body, Environment):-
 244         atom(Atom),
 245         !,
 246         lisp_error_description(unbound_atom, ErrMsg),
 247         Body = (once((  member(Bindings, Environment),
 248                         member(binding(Atom, Value0), Bindings),
 249                         extract_variable_value(Value0, Value, _)
 250                     ;   special_var(Atom, Value)
 251                     ;   throw(error(unbound_atom(Atom), context(atom, ErrMsg))) ))      ).
 252
 253 % Non built-in function expands into an explicit function call
 254 expand_function_body(Function, Result, Body, Environment):-
 255         !,
 256         Function =.. [FunctionName | FunctionArgs],
 257         % compound_name_arguments(Function, FunctionName, FunctionArgs),
 258         expand_arguments(FunctionArgs, ArgBody, Args, Environment),
 259         append(Args, [Result], ArgsResult),
 260         ExpandedFunction =.. [FunctionName | ArgsResult],
 261         % compound_name_arguments(ExpandedFunction, FunctionName, ArgsResult),
 262         Body = (        ArgBody,
 263                         ExpandedFunction        ).
 264
 265         expand_arguments([], true, [], _Environment).
 266         expand_arguments([Arg|Args], Body, [Result|Results], Environment):-
 267                 expand_function_body(Arg, Result, ArgBody, Environment),
 268                 Body = (ArgBody, ArgsBody),
 269                 expand_arguments(Args, ArgsBody, Results, Environment).
 270
 271
 272 expand_progn([], Result, Result, true, _Environment).
 273 expand_progn([Form | Forms], _PreviousResult, Result, Body, Environment):-
 274         expand_function_body(Form, FormResult, FormBody, Environment),
 275         Body = (FormBody, FormsBody),
 276         expand_progn(Forms, FormResult, Result, FormsBody, Environment).
 277
 278
 279 % Now Prolog can understand them, compile the additional library files
 280
 281 :- ensure_loaded(builtin_lisp_functions).
 282 :- ensure_loaded(lisp_library).