1/*******************************************************************
    2 *
    3 * A Common Lisp compiler/interpretor, written in Prolog
    4 *
    5 * This program provides some built-in functionality for the 
    6 * Lisp compiler.  It requires that the file lisp_compiler.pl has 
    7 * already been successfully compiled.
    8 *
    9 * Definitions in this file are given in the Lisp-like syntax 
   10 * read by this compiler.
   11*  ..............................
   12 *
   13 *
   14 * Neil''s Notes:
   15 *
   16 * (c) Neil Smith, 2001
   17 *
   18 * This program, and its associated support files, forms a compiler
   19 * for a subset of the language LISP.  It supports a few simple
   20 * built-in procedures, listed below.  It also supports both special
   21 * and lexical variables, and higher-order functions and lexical
   22 * closures.
   23 *
   24 * This compiler was written in LPA Prolog v3.6 under MS Windows.
   25 * It should run under other Prologs without too much conversion needed,
   26 * but note the required library modules.
   27 *
   28 *
   29 * Special forms
   30 *
   31 * [] and nil are treated as special forms, evaluating to [], and treated as 'false'
   32 * t is a special form, evaluating to t, and treated as 'true'
   33 * if, cond
   34 * progn (and implicit progn in defun and let bodies)
   35 * quote
   36 * let
   37 * setq
   38 * function
   39 * lambda
   40 * defvar, defparameter (both with and without initial values)
   41 *
   42 * Built-in procedures (defined in builtin_lisp_functions.pl)
   43 *
   44 * cons, first, rest, null
   45 * eq, equalp
   46 * plus, minus, times, divide
   47 * lisp_not, or, and
   48 * cl_apply
   49 *
   50 * Other procedures are defined in lisp_library.pl
   51 *
   52 *******************************************************************/
   53
   54
   55:- op(1200, xfx, <<== ).	% function definition
   56:- op(1200,  fx, <<== ).	% functional imperative definition
   57
   58% :- ensure_loaded(builtin_lisp_functions). % Lisp primitives: this directives is at the end of the file
   59% :- ensure_loaded(lisp_library).	% Functions defined in lisp: this directive is at the end of the file
   60					% allowing them to be compiled correctly
   61
   62
   63% The hook into the compiler
   64
   65lisp_compiler_term_expansion( (FunctionHeadP <<== FunctionBodyP),PrologCode):-                 
   66        must_det_l((expand_pterm_to_sterm(FunctionHeadP,FunctionHead),
   67        expand_pterm_to_sterm(FunctionBodyP,FunctionBody),        
   68        FunctionHead=[Name|FormalParams],
   69        lisp_compile([defun,Head,FormalParams,FunctionBody],ResultCode),
   70        asserts_to_prolog_code(ResultCode,PrologCode).
   71
   72asserts_to_prolog_code((A,B),PrologCode):-!,
   73        asserts_to_prolog_code(A,AA),
   74        asserts_to_prolog_code(B,BB),
   75        append(AA,BB,PrologCode).
   76
   77asserts_to_prolog_code(A,[AA]):- is_assert_op(A,_Where,AA),!.
   78asserts_to_prolog_code(:-A, AA):-!,asserts_to_prolog_code(A,AA).
   79asserts_to_prolog_code(A, [:-A]).
   80
   81lisp_compiler_term_expansion( ( <<== FunctionBodyP), ( :-   (Code, writeExpression(Result)) ):-
   82        must_det_l((expand_pterm_to_sterm(FunctionBodyP,FunctionBody),
   83        lisp_compile(Result,FunctionBody,Body),
   84        body_cleanup_keep_debug_vars(Ctx,Body,Code))).
   85
   86
   87ssip_compiler_term_expansion(Symbol,lambda(Args,Body),[OOUT]):- atom(Symbol),is_list(Args),
   88  length(Args,A1),
   89  A is A1+1,
   90  cfunctor(P,Symbol,A),
   91 (predicate_property(P,defined)->gensym(Symbol,SymbolR);Symbol=SymbolR),
   92  Head=..[SymbolR|Args],
   93  subst(Body,Symbol,SymbolR,BodyM),
   94  OUT= ((Head <<== BodyM)),
   95  always(lisp_compiler_term_expansion(OUT,OOUT)),!.
   96
   97ssip_compiler_term_expansion(Symbol,Symbol2,ssip_define(Symbol,Symbol2)):-!.
   98
   99% The hook into the compiler
  100term_expansion(Symbol==Function,O) :- I= (Symbol==Function),ssip_compiler_term_expansion(Symbol,Function,O),nl,nl,
  101  flatten([I,O],L),
  102  maplist(dbginfo,L),!.
  103  % in_cmt(maplist(portray_clause,L)),!.
  104term_expansion(I,O) :- lisp_compiler_term_expansion(I,O),I\==O,nl,nl,
  105  flatten([I,O],L),
  106  maplist(dbginfo,L),!.
  107
  108
  109% Now Prolog can understand them, compile the additional library files
  117fact == lambda([n], if(=(n,0),1,n*fact(sub1(n)))).
  118
  119
  120add1 == lambda([n], n+1).
  121
  122sub1 == lambda([n], n-1).
  123
  124% higher order functions
  125
  126mapcar ==
  127  lambda([fun,l],
  128         if(null(l),
  129            nil,
  130            cons(fun(car(l)),mapcar(fun,cdr(l))))).
  131
  132% simple list manipulation functions.
  133
  134length == lambda([l], if(null(l),0,add1(length(cdr(l))))).
  135
  136append == lambda([l1,l2],if(null(l1),l2,cons(car(l1),append(cdr(l1),l2)))).
  137
  138
  139% stuff for streams.
  140
  141filter ==
  142  lambda([fun,s],
  143         if('emptyStream?'(s),
  144            s,
  145            if(fun(head(s)),
  146               consStream(head(s),filter(fun,tail(s))),
  147               filter(fun,tail(s))))).
  148
  149from(n) <<== consStream(n,from(n+1)).
  150% from == lambda([n],consStream(n,from(n+1))).
  151
  152nthStream == lambda([s,n],if(n=1,head(s),nthStream(tail(s),n-1))).
  153
  154integers == from(1).
  155
  156% environments
  157
  158makeCounter ==
  159  lambda([],
  160         begin(counter == 0,
  161               lambda([],setq(counter,1+counter)))).
  162
  163caaaar == lambda([x],car(car(car(car(x))))).
  164
  165caar == lambda([x],car(car(x))).
  166
  167reverse ==
  168  lambda([l],
  169     if(null(l),
  170        l,
  171        append(reverse(cdr(l)),(cons(car(l),nil))))).
  172
  173
  174second(l) <<== 
  175	first(rest(l)).
  176
  177third(l) <<==
  178	first(rest(rest(l))).
  179
  180
  181% We don't support &rest parameters yet, so we need a different
  182% definition of list for every different number of arguments
  183
  184list_1(a) <<== 
  185	cons(a, nil).
  186
  187list_2(a, b) <<== 
  188	cons(a, list_1(b)).
  189
  190list_3(a, b, c) <<== 
  191	cons(a, list_2(b,c)).
  192
  193
  194lisp_append(l1, l2) <<==
  195	if( null(l1), 
  196	    l2, 
  197	    cons( first(l1),
  198	          lisp_append(rest(l1),
  199	                      l2))).
  200 
  201
  202mapcar(func, l) <<==
  203	if( null(l), 
  204		nil,
  205		cons( cl_apply(func, list_1(first(l))),
  206			mapcar(func, rest(l)))).
  207
  208
  209/*******************************************************************
  210 *
  211 * A Common Lisp compiler/interpretor, written in Prolog
  212 *
  213 * (tests.pl)
  214 *
  215 * (c) Neil Smith, 2001
  216 *
  217 * A few sample function definitions, mainly used by me as simple 
  218 * test cases for the compiler.  I'm sure you can come up with 
  219 * something better...
  220 *
  221 *******************************************************************/
  222
  223
  224simple(x) <<== x.
  225
  226
  227lisp_append_2(l1, l2) <<==
  228	cond(  [[null(l1), l2], 
  229		[t,	cons( first(l1),
  230			      lisp_append_2(rest(l1),
  231			                    l2))]]).
  232 
  233
  234lisp_error(x) <<== setq(y, 5).
  235
  236%:- rtrace.
  237lisp_let() <<==
  238	let([bind(x, 3), bind(y, 5)], 
  239		      progn(x,y)).
  240
  241lisp_let1() <<==
  242	let([bind(x, 3), bind(y, 5)], 
  243			x, 		% implicit progn here
  244			y).
  245
  246
  247% maps 'first' over a list of lists
  248mapfirst(l) <<==
  249	mapcar(function(first), l).
  250
  251
  252<<== defvar(fred, 13).
  253
  254<<== defvar(george).
  255
  256
  257reset_george(val) <<==
  258	setq(george, val).
  259
  260
  261make_adder(x) <<==
  262	function(lambda([y], plus(x, y))).
  263
  264
  265scale_list(xs, scale) <<==
  266	let([bind(fred, function(lambda([num], times(scale, num))))], mapcar(fred, xs)).
  267
  268
  269make_summer(total) <<== 
  270	function(lambda([n],
  271		setq(total, plus(total, n)))).
  272
  273
  274sum_with_map(xs) <<==
  275	let([bind(running_total, 0)],
  276		let([bind(summer, function(lambda([n], setq(running_total, 
  277							plus(running_total, n)))))],
  278		 mapcar(summer, xs),
  279		  running_total )).
  280
  281
  282
  283:- fixup_exports.