53
54
55:- op(1200, xfx, <<== ). 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
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 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
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
125
126mapcar ==
127 lambda([fun,l],
128 if(null(l),
129 nil,
130 cons(fun(car(l)),mapcar(fun,cdr(l))))).
131
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
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)).
151
152nthStream == lambda([s,n],if(n=1,head(s),nthStream(tail(s),n-1))).
153
154integers == from(1).
155
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
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
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
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, 244 y).
245
246
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.