turbolisp
Fork

Fork origin:

AlaskanEmily/turbolisp

R/O
HTTP
SSH
HTTPS

Commit

Commit MetaInfo

Revision	bbe281179bed7d4ec2e9f102648a12ebd87d631e (tree)
Time	2019-07-28 06:29:30
Author	AlaskanEmily <emily@alas...>
Commiter	AlaskanEmily

Log Message

Remove modules which were supposed to be renamed

Change Summary

delete: tl_runtime.builtin.arithmetic.m
delete: tl_runtime.builtin.comparison.m
delete: tl_runtime.builtin.m
delete: tl_runtime.m

Incremental Difference

--- a/tl_runtime.builtin.arithmetic.m

+++ /dev/null

		@@ -1,165 +0,0 @@
1		-:- module tl_runtime.builtin.arithmetic.
2		-
3		-%=============================================================================%
4		-% Turbolisp implementation details for arithmetic builtins.
5		-:- interface.
6		-%=============================================================================%
7		-
8		-:- func int_to_float(int::in) = (float::uo) is det.
9		-
10		-%-----------------------------------------------------------------------------%
11		-
12		-:- func inc(int) = int.
13		-
14		-%-----------------------------------------------------------------------------%
15		-
16		-:- type math_pred == (pred(number, number, string)).
17		-:- mode math_pred == (pred(in, in, uo) is det).
18		-:- inst math_pred == (pred(in, in, uo) is det).
19		-
20		-%-----------------------------------------------------------------------------%
21		-% TODO: Variadic + and *?
22		-:- pred builtin_plus `with_type` math_pred `with_inst` math_pred.
23		-:- pred builtin_minus `with_type` math_pred `with_inst` math_pred.
24		-:- pred builtin_times `with_type` math_pred `with_inst` math_pred.
25		-:- pred builtin_divide `with_type` math_pred `with_inst` math_pred.
26		-
27		-%-----------------------------------------------------------------------------%
28		-
29		-:- pred builtin_arithmetic_bind(math_pred, arithmetic, list(element), result).
30		-:- mode builtin_arithmetic_bind(math_pred, in, in, res_uo) is det.
31		-
32		-%=============================================================================%
33		-% Most of the implementation of the arithmetic submodule is private.
34		-:- implementation.
35		-%=============================================================================%
36		-
37		-:- use_module int.
38		-:- import_module float.
39		-
40		-%-----------------------------------------------------------------------------%
41		-
42		-:- pragma inline(int_to_float/1).
43		-
44		-%-----------------------------------------------------------------------------%
45		-
46		-int_to_float(I) = ((0.0)+float(I)).
47		-
48		-%-----------------------------------------------------------------------------%
49		-
50		-inc(I) = int.plus(I, 1).
51		-
52		-%-----------------------------------------------------------------------------%
53		-
54		-:- func float_plus(float::in, float::in) = (float::uo) is det.
55		-:- func float_minus(float::in, float::in) = (float::uo) is det.
56		-:- func float_times(float::in, float::in) = (float::uo) is det.
57		-:- func float_divide(float::in, float::in) = (float::uo) is det.
58		-
59		-float_plus(A, B) = (A+B).
60		-float_minus(A, B) = (A-B).
61		-float_times(A, B) = (A*B).
62		-float_divide(A, B) = (A/B).
63		-
64		-%-----------------------------------------------------------------------------%
65		-
66		-:- pred two_atoms(element, element, maybe.maybe_error({string, string})).
67		-:- mode two_atoms(in, in, out(maybe_unique_error)) is det.
68		-
69		-two_atoms(list(_), list(_), maybe.error("Args 1 and 2 not atoms")).
70		-two_atoms(atom(_), list(_), maybe.error("Arg 2 not atom")).
71		-two_atoms(list(_), atom(_), maybe.error("Arg 1 not atom")).
72		-two_atoms(atom(A), atom(B), maybe.ok({A, B})).
73		-
74		-:- pragma inline(two_atoms/3).
75		-
76		-%-----------------------------------------------------------------------------%
77		-
78		-:- pred two_atoms(list.list(element), maybe.maybe_error({string, string})).
79		-:- mode two_atoms(in, out(maybe_unique_error)) is det.
80		-
81		-:- pragma inline(two_atoms/2).
82		-
83		-two_atoms(Args, Result) :-
84		- (
85		- Args = [],
86		- Result = maybe.error("no values")
87		- ;
88		- Args = [_\|[]],
89		- Result = maybe.error("not 2 values (1)")
90		- ;
91		- Args = [_\|[_\|[_\|_]]],
92		- Result = maybe.error(string.append(string.append(
93		- "not 2 values (", string.from_int(list.length(Args))),
94		- ")"))
95		- ;
96		- Args = [A\|[B\|[]]],
97		- two_atoms(A, B, Result)
98		- ).
99		-
100		-%-----------------------------------------------------------------------------%
101		-
102		-:- func arithmetic(func(int, int) = int, func(float, float) = float,
103		- number, number) = (string).
104		-:- mode arithmetic(func(in, in) = (out) is det, func(in, in) = (uo) is det,
105		- in, in) = (uo) is det.
106		-
107		-arithmetic(Func, _, int(A), int(B)) = string.from_int(Func(A, B)).
108		-arithmetic(_, Func, float(A), float(B)) = string.from_float(Func(A, B)).
109		-arithmetic(_, Func, int(A), float(B)) = string.from_float(Func(float(A), B)).
110		-arithmetic(_, Func, float(A), int(B)) = string.from_float(Func(A, float(B))).
111		-
112		-%-----------------------------------------------------------------------------%
113		-
114		-builtin_plus(ANum, BNum, arithmetic(int.plus, float_plus, ANum, BNum)).
115		-builtin_minus(ANum, BNum, arithmetic(int.minus, float_minus, ANum, BNum)).
116		-builtin_times(ANum, BNum, arithmetic(int.times, float_times, ANum, BNum)).
117		-builtin_divide(ANum, BNum, arithmetic('int__div', float_divide, ANum, BNum)).
118		-
119		-%-----------------------------------------------------------------------------%
120		-% Implementation of arithmetic operators.
121		-:- pred arithmetic(math_pred,
122		- arithmetic, list.list(element), result).
123		-:- mode arithmetic(math_pred,
124		- in, in, res_uo) is det.
125		-
126		-:- pragma inline(arithmetic/4).
127		-
128		-arithmetic(Pred, Op, Args, Result) :-
129		- two_atoms(Args, ArgsResult),
130		- (
131		- ArgsResult = maybe.error(Error),
132		- builtin_op_tag(arithmetic(Op), Tag),
133		- Result = maybe.error(func_error(Tag, 2, Error))
134		- ;
135		- ArgsResult = maybe.ok({AStr, BStr}),
136		- ( if
137		- number_type(AStr, ANum)
138		- then
139		- ( if
140		- number_type(BStr, BNum)
141		- then
142		- Pred(ANum, BNum, Out),
143		- Result = maybe.ok(atom(Out))
144		- else
145		- builtin_op_tag(arithmetic(Op), Tag),
146		- Result = maybe.error(func_error(
147		- Tag,
148		- 2,
149		- string.append(string.append(
150		- "arg 2 not a number (", BStr), ")")))
151		- )
152		- else
153		- builtin_op_tag(arithmetic(Op), Tag),
154		- Result = maybe.error(func_error(
155		- Tag,
156		- 2,
157		- string.append(string.append(
158		- "arg 1 not a number (", AStr), ")")))
159		- )
160		- ).
161		-
162		-%-----------------------------------------------------------------------------%
163		-
164		-builtin_arithmetic_bind(Pred, Op, Args, Out) :- arithmetic(Pred, Op, Args, Out).
165		-

--- a/tl_runtime.builtin.comparison.m

+++ /dev/null

		@@ -1,77 +0,0 @@
1		-:- module tl_runtime.builtin.comparison.
2		-
3		-%=============================================================================%
4		-% Turbolisp implementation details for comparison builtins.
5		-:- interface.
6		-%=============================================================================%
7		-
8		-:- func inverse(cmp_result) = cmp_result.
9		-:- mode inverse(di) = (uo) is det.
10		-:- mode inverse(in) = (out) is det.
11		-
12		-%-----------------------------------------------------------------------------%
13		-
14		-:- pred builtin_comparison_bind(cmp_pred, list(element), result, runtime, runtime).
15		-:- mode builtin_comparison_bind(cmp_pred, in, res_uo, in, out) is det.
16		-
17		-%-----------------------------------------------------------------------------%
18		-
19		-:- pred atom_compare(string::in, string::in, comparison_result::uo) is det.
20		-
21		-%=============================================================================%
22		-:- implementation.
23		-%=============================================================================%
24		-
25		-:- use_module exception.
26		-
27		-%-----------------------------------------------------------------------------%
28		-
29		-:- pragma inline(builtin_comparison_bind/5).
30		-:- pragma inline(inverse/1).
31		-
32		-%-----------------------------------------------------------------------------%
33		-
34		-inverse(error(Error)) = error(Error).
35		-inverse(yes) = no.
36		-inverse(no) = yes.
37		-
38		-%-----------------------------------------------------------------------------%
39		-
40		-builtin_comparison_bind(Pred, Args, Result, !Runtime) :-
41		- ( if
42		- Args = [A, B, Y, N]
43		- then
44		- Pred(A, B, CmpResult),
45		- (
46		- CmpResult = yes,
47		- Result = maybe.ok(Y)
48		- ;
49		- CmpResult = no,
50		- Result = maybe.ok(N)
51		- ;
52		- CmpResult = error(Error),
53		- Result = maybe.error(Error)
54		- )
55		- else
56		- exception.throw(exception.software_error(
57		- "Wrong arity in comparison func (builtin_bind is probably broken)"))
58		- ).
59		-
60		-%-----------------------------------------------------------------------------%
61		-
62		-atom_compare(A, B, Cmp) :-
63		- ( if
64		- number_type(A, ANum),
65		- number_type(B, BNum)
66		- then
67		- ( if
68		- as_int(ANum, BNum, AInt, BInt)
69		- then
70		- builtin.compare(Cmp, AInt, BInt)
71		- else
72		- promote(ANum, BNum, AFloat, BFloat),
73		- builtin.compare(Cmp, AFloat, BFloat)
74		- )
75		- else
76		- builtin.compare(Cmp, A, B)
77		- ).

--- a/tl_runtime.builtin.m

+++ /dev/null

		@@ -1,476 +0,0 @@
1		-:- module tl_runtime.builtin.
2		-
3		-%=============================================================================%
4		-% Turbolisp builtins
5		-:- interface.
6		-%=============================================================================%
7		-
8		-:- use_module enum.
9		-
10		-%-----------------------------------------------------------------------------%
11		-
12		-:- type arithmetic --->
13		- plus ;
14		- minus ;
15		- times ;
16		- divide.
17		-
18		-%-----------------------------------------------------------------------------%
19		-
20		-:- instance enum.enum(arithmetic).
21		-
22		-%-----------------------------------------------------------------------------%
23		-
24		-:- type logic --->
25		- int_and ;
26		- int_or ;
27		- int_xor.
28		-
29		-%-----------------------------------------------------------------------------%
30		-
31		-:- instance enum.enum(logic).
32		-
33		-%-----------------------------------------------------------------------------%
34		-
35		-:- type comparison --->
36		- eq ;
37		- ne ;
38		- lt ;
39		- gt ;
40		- le ;
41		- ge.
42		-
43		-%-----------------------------------------------------------------------------%
44		-
45		-:- instance enum.enum(comparison).
46		-
47		-%-----------------------------------------------------------------------------%
48		-
49		-:- pred comparison_tag(comparison, string).
50		-:- mode comparison_tag(in, out) is det.
51		-:- mode comparison_tag(out, in) is semidet.
52		-:- mode comparison_tag(out, ui) is semidet. % Iffy
53		-:- mode comparison_tag(in, in) is semidet. % Implied
54		-
55		-%-----------------------------------------------------------------------------%
56		-
57		-:- type define --->
58		- def ;
59		- let ;
60		- fn.
61		-
62		-%-----------------------------------------------------------------------------%
63		-
64		-:- instance enum.enum(define).
65		-
66		-%-----------------------------------------------------------------------------%
67		-
68		-:- type builtin_op --->
69		- arithmetic(arithmetic) ;
70		- logic(logic) ;
71		- comparison(comparison) ;
72		- define(define).
73		-
74		-%-----------------------------------------------------------------------------%
75		-
76		-:- instance enum.enum(builtin_op).
77		-
78		-%-----------------------------------------------------------------------------%
79		-
80		-:- pred builtin_op_enum(builtin_op, int).
81		-:- mode builtin_op_enum(in, out) is det.
82		-:- mode builtin_op_enum(out, in) is semidet.
83		-:- mode builtin_op_enum(in, in) is semidet. % Implied
84		-
85		-%-----------------------------------------------------------------------------%
86		-
87		-:- pred builtin_op_tag(builtin_op, string).
88		-:- mode builtin_op_tag(in, out) is det.
89		-:- mode builtin_op_tag(out, in) is semidet.
90		-:- mode builtin_op_tag(out, ui) is semidet. % Iffy
91		-:- mode builtin_op_tag(in, in) is semidet. % Implied
92		-
93		-%-----------------------------------------------------------------------------%
94		-% Numeric components shared between comparison, arithmetic, and logic.
95		-%-----------------------------------------------------------------------------%
96		-
97		-% Used to determine if a number is a float or an int.
98		-:- type number ---> float(float) ; int(int).
99		-
100		-%-----------------------------------------------------------------------------%
101		-% Promotes both numbers to floats.
102		-:- pred promote(number::in, number::in, float::out, float::out) is det.
103		-
104		-%-----------------------------------------------------------------------------%
105		-% Unifies iff both numbers are the integer functor for the ints
106		-:- pred as_int(number, number, int, int).
107		-:- mode as_int(in, in, out, out) is semidet.
108		-:- mode as_int(di, di, uo, uo) is semidet.
109		-:- mode as_int(out, out, in, in) is det.
110		-:- mode as_int(uo, uo, di, di) is det.
111		-:- mode as_int(in, in, in, in) is semidet. % Implied.
112		-
113		-%-----------------------------------------------------------------------------%
114		-% number_type(NumStr, Num)
115		-:- pred number_type(string::in, number::uo) is semidet.
116		-
117		-%-----------------------------------------------------------------------------%
118		-% Comparison components.
119		-%-----------------------------------------------------------------------------%
120		-
121		-% Result of the builtin comparisons.
122		-:- type cmp_result ---> yes ; no ; error(string).
123		-
124		-%-----------------------------------------------------------------------------%
125		-% Runs the builtin comparison predicate.
126		-:- pred comparison(comparison, element, element, cmp_result).
127		-:- mode comparison(in, in, in, uo) is det.
128		-
129		-%-----------------------------------------------------------------------------%
130		-
131		-:- type cmp_pred == (pred(element, element, cmp_result)).
132		-:- mode cmp_pred == (pred(in, in, uo) is det).
133		-:- inst cmp_pred == (pred(in, in, uo) is det).
134		-
135		-%-----------------------------------------------------------------------------%
136		-% Comparison builtins. These are aggressively inlined by the compilation
137		-% phase, so they must be exported to the runtime.
138		-:- pred builtin_eq `with_type` cmp_pred `with_inst` cmp_pred.
139		-:- pred builtin_ne `with_type` cmp_pred `with_inst` cmp_pred.
140		-:- pred builtin_lt `with_type` cmp_pred `with_inst` cmp_pred.
141		-:- pred builtin_gt `with_type` cmp_pred `with_inst` cmp_pred.
142		-:- pred builtin_le `with_type` cmp_pred `with_inst` cmp_pred.
143		-:- pred builtin_ge `with_type` cmp_pred `with_inst` cmp_pred.
144		-
145		-%-----------------------------------------------------------------------------%
146		-
147		-:- pred builtin_eq_bind `with_type` execute_pred `with_inst` execute_pred.
148		-:- pred builtin_ne_bind `with_type` execute_pred `with_inst` execute_pred.
149		-:- pred builtin_lt_bind `with_type` execute_pred `with_inst` execute_pred.
150		-:- pred builtin_gt_bind `with_type` execute_pred `with_inst` execute_pred.
151		-:- pred builtin_le_bind `with_type` execute_pred `with_inst` execute_pred.
152		-:- pred builtin_ge_bind `with_type` execute_pred `with_inst` execute_pred.
153		-
154		-%-----------------------------------------------------------------------------%
155		-% Arithmetic components.
156		-%-----------------------------------------------------------------------------%
157		-
158		-:- pred builtin_plus_bind `with_type` execute_pred `with_inst` execute_pred.
159		-:- pred builtin_minus_bind `with_type` execute_pred `with_inst` execute_pred.
160		-:- pred builtin_times_bind `with_type` execute_pred `with_inst` execute_pred.
161		-:- pred builtin_divide_bind `with_type` execute_pred `with_inst` execute_pred.
162		-
163		-%-----------------------------------------------------------------------------%
164		-% Define components.
165		-%-----------------------------------------------------------------------------%
166		-
167		-:- pred builtin_let_bind `with_type` execute_pred `with_inst` execute_pred.
168		-:- pred builtin_def_bind `with_type` execute_pred `with_inst` execute_pred.
169		-:- pred builtin_fn_bind `with_type` execute_pred `with_inst` execute_pred.
170		-
171		-%=============================================================================%
172		-:- implementation.
173		-%=============================================================================%
174		-
175		-:- use_module char.
176		-:- use_module exception.
177		-
178		-:- include_module tl_runtime.builtin.comparison.
179		-:- import_module tl_runtime.builtin.comparison.
180		-
181		-:- include_module tl_runtime.builtin.arithmetic.
182		-:- import_module tl_runtime.builtin.arithmetic.
183		-
184		-%-----------------------------------------------------------------------------%
185		-
186		-:- pragma inline(comparison/4).
187		-:- pragma inline(builtin_op_tag/2).
188		-:- pragma inline(builtin_op_enum/2).
189		-
190		-%-----------------------------------------------------------------------------%
191		-
192		-:- pragma inline(comparison/4).
193		-:- pragma inline(builtin_eq/3).
194		-:- pragma inline(builtin_lt/3).
195		-:- pragma inline(builtin_gt/3).
196		-:- pragma inline(builtin_le/3).
197		-:- pragma inline(builtin_ge/3).
198		-
199		-%-----------------------------------------------------------------------------%
200		-
201		-:- instance enum.enum(arithmetic) where [
202		- ( to_int(E) = I :- builtin_op_enum(arithmetic(E), I) ),
203		- ( from_int(I) = E :- builtin_op_enum(arithmetic(E), I) )
204		-].
205		-
206		-%-----------------------------------------------------------------------------%
207		-
208		-:- instance enum.enum(logic) where [
209		- ( to_int(E) = I :- builtin_op_enum(logic(E), I) ),
210		- ( from_int(I) = E :- builtin_op_enum(logic(E), I) )
211		-].
212		-
213		-%-----------------------------------------------------------------------------%
214		-
215		-:- instance enum.enum(comparison) where [
216		- ( to_int(E) = I :- builtin_op_enum(comparison(E), I) ),
217		- ( from_int(I) = E :- builtin_op_enum(comparison(E), I) )
218		-].
219		-
220		-%-----------------------------------------------------------------------------%
221		-
222		-comparison_tag(Cmp, Tag) :-
223		- builtin_op_tag(comparison(Cmp), Tag).
224		-
225		-%-----------------------------------------------------------------------------%
226		-
227		-:- instance enum.enum(define) where [
228		- ( to_int(E) = I :- builtin_op_enum(define(E), I) ),
229		- ( from_int(I) = E :- builtin_op_enum(define(E), I) )
230		-].
231		-
232		-%-----------------------------------------------------------------------------%
233		-
234		-:- instance enum.enum(builtin_op) where [
235		- ( to_int(E) = I :- builtin_op_enum(E, I) ),
236		- ( from_int(I) = E :- builtin_op_enum(E, I) )
237		-].
238		-
239		-%-----------------------------------------------------------------------------%
240		-
241		-builtin_op_enum(arithmetic(plus), 0).
242		-builtin_op_enum(arithmetic(minus), 1).
243		-builtin_op_enum(arithmetic(times), 2).
244		-builtin_op_enum(arithmetic(divide), 3).
245		-builtin_op_enum(logic(int_and), 4).
246		-builtin_op_enum(logic(int_or), 5).
247		-builtin_op_enum(logic(int_xor), 6).
248		-builtin_op_enum(comparison(eq), 7).
249		-builtin_op_enum(comparison(ne), 8).
250		-builtin_op_enum(comparison(lt), 9).
251		-builtin_op_enum(comparison(gt), 10).
252		-builtin_op_enum(comparison(le), 11).
253		-builtin_op_enum(comparison(ge), 12).
254		-builtin_op_enum(define(def), 13).
255		-builtin_op_enum(define(let), 14).
256		-builtin_op_enum(define(fn), 15).
257		-
258		-%-----------------------------------------------------------------------------%
259		-
260		-builtin_op_tag(arithmetic(plus), "+").
261		-builtin_op_tag(arithmetic(minus), "-").
262		-builtin_op_tag(arithmetic(times), "*").
263		-builtin_op_tag(arithmetic(divide), "/").
264		-builtin_op_tag(logic(int_and), "&").
265		-builtin_op_tag(logic(int_or), "\|").
266		-builtin_op_tag(logic(int_xor), "^").
267		-builtin_op_tag(comparison(eq), "=").
268		-builtin_op_tag(comparison(ne), "!").
269		-builtin_op_tag(comparison(lt), "<").
270		-builtin_op_tag(comparison(gt), ">").
271		-builtin_op_tag(comparison(le), "<=").
272		-builtin_op_tag(comparison(ge), ">=").
273		-builtin_op_tag(define(def), "def").
274		-builtin_op_tag(define(let), "let").
275		-builtin_op_tag(define(fn), "fn").
276		-
277		-%-----------------------------------------------------------------------------%
278		-
279		-comparison(eq, E1, E2, Result) :- builtin_eq(E1, E2, Result).
280		-comparison(ne, E1, E2, Result) :- builtin_ne(E1, E2, Result).
281		-comparison(lt, E1, E2, Result) :- builtin_lt(E1, E2, Result).
282		-comparison(gt, E1, E2, Result) :- builtin_gt(E1, E2, Result).
283		-comparison(le, E1, E2, Result) :- builtin_le(E1, E2, Result).
284		-comparison(ge, E1, E2, Result) :- builtin_ge(E1, E2, Result).
285		-
286		-%-----------------------------------------------------------------------------%
287		-
288		-promote(float(A), float(B), A, B).
289		-promote(int(A), float(B), int_to_float(A), B).
290		-promote(float(A), int(B), A, int_to_float(B)).
291		-promote(int(A), int(B), int_to_float(A), int_to_float(B)).
292		-
293		-%-----------------------------------------------------------------------------%
294		-
295		-as_int(int(A), int(B), A, B).
296		-
297		-%-----------------------------------------------------------------------------%
298		-
299		-:- pred digit_or_dot(character::in) is semidet.
300		-digit_or_dot(C) :-
301		- ( not C = ('.') ) => char.is_digit(C).
302		-
303		-%-----------------------------------------------------------------------------%
304		-
305		-number_type(In, Out) :-
306		- ( if
307		- string.all_match(char.is_digit, In)
308		- then
309		- string.to_int(In, Int),
310		- builtin__copy(Int, UniqInt),
311		- Out = int(UniqInt)
312		- else if
313		- string.all_match(digit_or_dot, In)
314		- then
315		- string.to_float(In, Float),
316		- builtin__copy(Float, UniqFloat),
317		- Out = float(UniqFloat)
318		- else
319		- string.remove_prefix("0x", In, InP),
320		- string.all_match(char.is_hex_digit, InP),
321		- string.base_string_to_int(16, InP, Int),
322		- builtin__copy(Int, UniqInt),
323		- Out = int(UniqInt)
324		- ).
325		-
326		-%-----------------------------------------------------------------------------%
327		-
328		-builtin_eq(A, B, Result) :- ( A = B -> Result = yes ; Result = no ).
329		-
330		-builtin_ne(A, B, Result) :- ( A = B -> Result = no ; Result = yes ).
331		-
332		-builtin_lt(list(_), list(_), error("Error: `lt/2` -> test two lists")).
333		-builtin_lt(atom(_), list(_), error("Error: `lt/2` -> test atom and list")).
334		-builtin_lt(list(_), atom(_), error("Error: `lt/2` -> test list and atom")).
335		-builtin_lt(atom(A), atom(B), Result) :-
336		- ( atom_compare(A, B, (<)) -> Result = yes ; Result = no ).
337		-
338		-builtin_gt(list(_), list(_), error("Error: `gt/2` -> test two lists")).
339		-builtin_gt(atom(_), list(_), error("Error: `gt/2` -> test atom and list")).
340		-builtin_gt(list(_), atom(_), error("Error: `gt/2` -> test list and atom")).
341		-builtin_gt(atom(A), atom(B), Result) :-
342		- ( atom_compare(A, B, (>)) -> Result = yes ; Result = no ).
343		-
344		-builtin_le(list(_), list(_), error("Error: `le/2` -> test two lists")).
345		-builtin_le(atom(_), list(_), error("Error: `le/2` -> test atom and list")).
346		-builtin_le(list(_), atom(_), error("Error: `le/2` -> test list and atom")).
347		-builtin_le(atom(A), atom(B), Result) :-
348		- ( atom_compare(A, B, (>)) -> Result = no ; Result = yes ).
349		-
350		-builtin_ge(list(_), list(_), error("Error: `ge/2` -> test two lists")).
351		-builtin_ge(atom(_), list(_), error("Error: `ge/2` -> test atom and list")).
352		-builtin_ge(list(_), atom(_), error("Error: `ge/2` -> test list and atom")).
353		-builtin_ge(atom(A), atom(B), Result) :-
354		- ( atom_compare(A, B, (<)) -> Result = no ; Result = yes ).
355		-
356		-%-----------------------------------------------------------------------------%
357		-
358		-builtin_eq_bind(E, R, !RT) :- builtin_comparison_bind(builtin_eq, E, R, !RT).
359		-builtin_ne_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ne, E, R, !RT).
360		-builtin_lt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_lt, E, R, !RT).
361		-builtin_gt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_gt, E, R, !RT).
362		-builtin_le_bind(E, R, !RT) :- builtin_comparison_bind(builtin_le, E, R, !RT).
363		-builtin_ge_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ge, E, R, !RT).
364		-
365		-%-----------------------------------------------------------------------------%
366		-
367		-builtin_plus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_plus, plus, E, R).
368		-builtin_minus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_minus, minus, E, R).
369		-builtin_times_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_times, times, E, R).
370		-builtin_divide_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_divide, divide, E, R).
371		-
372		-%-----------------------------------------------------------------------------%
373		-% Used to implement let and def
374		-
375		-%-----------------------------------------------------------------------------%
376		-% Used to parse argument names in fn/3
377		-:- pred fn_arg(element, string, int, int, maybe.maybe_error, maybe.maybe_error).
378		-:- mode fn_arg(in, out, in, out, di, uo) is det.
379		-%:- mode fn_arg(di, uo, in, out, di, uo) is det.
380		-
381		-fn_arg(_, "", I, inc(I), maybe.error(E), maybe.error(E)).
382		-fn_arg(list(_), "", I, inc(I), maybe.ok,
383		- maybe.error(string.append(string.append(
384		- "Error: `fn/3` -> Arg list element ",
385		- string.from_int(I)),
386		- " is a list"))).
387		-fn_arg(atom(Str), Str, I, inc(I), maybe.ok, maybe.ok).
388		-
389		-%-----------------------------------------------------------------------------%
390		-% Used to implement fn
391		-:- type fn_parse_result == {string, list(string), list(element), int}.
392		-:- pred fn_parse(list.list(element), maybe.maybe_error(fn_parse_result)).
393		-:- mode fn_parse(in, res_uo) is det.
394		-
395		-fn_parse(Element, Result) :-
396		- ( if
397		- Element = [NameElement\|[ArgsElement\|Body]]
398		- then
399		- (
400		- NameElement = list(_),
401		- Result = maybe.error("Error: `fn/3` -> arg 1 is a list")
402		- ;
403		- NameElement = atom(Name),
404		- (
405		- ArgsElement = atom(_),
406		- Result = maybe.error("Error: `fn/3` -> arg 2 is an atom")
407		- ;
408		- ArgsElement = list(Args),
409		- % Validate the arguments, and construct a list of names.
410		- list.map_foldl2(fn_arg,
411		- Args, ArgNames, 0, Arity, maybe.ok, ArgsResult),
412		- (
413		- ArgsResult = maybe.ok,
414		- Result = maybe.ok({Name, ArgNames, Body, Arity})
415		- ;
416		- ArgsResult = maybe.error(Error),
417		- Result = maybe.error(Error)
418		- )
419		- )
420		- )
421		- else
422		- exception.throw(exception.software_error(
423		- "Wrong arity in `fn/3` (builtin_bind is probably broken)"))
424		- ).
425		-
426		-%-----------------------------------------------------------------------------%
427		-
428		-builtin_fn_bind(Element, Result, !Runtime) :-
429		- fn_parse(Element, FnResult),
430		- (
431		- FnResult = maybe.error(Error),
432		- Result = maybe.error(Error)
433		- ;
434		- FnResult = maybe.ok({Name, ArgNames, Body, Arity}),
435		- def_bind(args(Name, Arity), lisp_bind(ArgNames, Body), !Runtime),
436		- Result = maybe.ok(atom(Name))
437		- ).
438		-
439		-%-----------------------------------------------------------------------------%
440		-
441		-builtin_def_bind(Element, Result, !Runtime) :-
442		- ( if
443		- Element = [NameElement\|[Value\|[]]]
444		- then
445		- (
446		- NameElement = atom(Name),
447		- !.Runtime ^ globals = Globals,
448		- !Runtime ^ globals := rbtree.set(Globals, Name, Value),
449		- Result = maybe.ok(Value)
450		- ;
451		- NameElement = list(_),
452		- Result = maybe.error("Error: `def/2` -> arg 1 is a list")
453		- )
454		- else
455		- exception.throw(exception.software_error(
456		- "Wrong arity in `def/2` (builtin_bind is probably broken)"))
457		- ).
458		-
459		-%-----------------------------------------------------------------------------%
460		-
461		-builtin_let_bind(Element, Result, !Runtime) :-
462		- ( if
463		- Element = [NameElement\|[Value\|[]]]
464		- then
465		- (
466		- NameElement = atom(Name),
467		- def_var(Name, Value, !Runtime),
468		- Result = maybe.ok(Value)
469		- ;
470		- NameElement = list(_),
471		- Result = maybe.error("Error: `let/2` -> arg 1 is a list")
472		- )
473		- else
474		- exception.throw(exception.software_error(
475		- "Wrong arity in `let/2` (builtin_bind is probably broken)"))
476		- ).

--- a/tl_runtime.m

+++ /dev/null

		@@ -1,800 +0,0 @@
1		-:- module tl_runtime.
2		-
3		-%=============================================================================%
4		-% Turbolisp Runtime.
5		-% This is separate from the Turbolisp module, which provides just an
6		-% S-expression parser. Depending on your inputs, that might be enough :)
7		-% Ideally we would also separate out the execute/reduce components, since you
8		-% usually don't want both.
9		-:- interface.
10		-%=============================================================================%
11		-
12		-:- import_module list.
13		-:- use_module assoc_list.
14		-:- use_module rbtree.
15		-:- use_module maybe.
16		-
17		-:- import_module turbolisp.
18		-
19		-%-----------------------------------------------------------------------------%
20		-% TODO!
21		-:- func nil = element.
22		-
23		-%-----------------------------------------------------------------------------%
24		-% Frames use an assoc list, as they are not expected to have a lot of elements,
25		-% and the extra allocations of a tree would quickly overwhelm the gains in
26		-% lookup speed.
27		-:- type frame --->
28		- frame(variables::assoc_list.assoc_list(string, element)).
29		-
30		-%-----------------------------------------------------------------------------%
31		-
32		-:- func init_frame = frame.
33		-
34		-%-----------------------------------------------------------------------------%
35		-
36		-:- func init_frame(assoc_list.assoc_list(string, element)) = frame.
37		-
38		-%-----------------------------------------------------------------------------%
39		-
40		-:- type result == maybe.maybe_error(element).
41		-
42		-%-----------------------------------------------------------------------------%
43		-
44		-:- inst maybe_unique_error --->
45		- maybe.ok(ground) ;
46		- maybe.error(unique).
47		-
48		-:- inst maybe_clobbered_error --->
49		- maybe.ok(ground) ;
50		- maybe.error(clobbered).
51		-
52		-:- mode res_uo == free >> maybe_unique_error.
53		-:- mode res_di == maybe_unique_error >> maybe_clobbered_error.
54		-
55		-%-----------------------------------------------------------------------------%
56		-
57		-:- type execute_pred == (pred(list.list(element), result, runtime, runtime)).
58		-:- inst execute_pred == (pred(in, res_uo, in, out) is det).
59		-:- mode execute_pred == (pred(in, res_uo, in, out) is det).
60		-
61		-:- type bind --->
62		- mercury_bind(pred(list.list(element)::in, result::res_uo, runtime::in, runtime::out) is det) ;
63		- lisp_bind(arg_names::list.list(string), body::list.list(element)).
64		-
65		-%-----------------------------------------------------------------------------%
66		-
67		-:- type bind_spec --->
68		- variadic(string) ;
69		- args(string, int).
70		-
71		-%-----------------------------------------------------------------------------%
72		-
73		-:- type variables == rbtree.rbtree(string, element).
74		-
75		-%-----------------------------------------------------------------------------%
76		-
77		-:- type runtime ---> runtime(
78		- globals::variables,
79		- binds::rbtree.rbtree(bind_spec, bind),
80		- stack_frames::list.list(frame),
81		- pending_io::list.list(string)).
82		-
83		-%-----------------------------------------------------------------------------%
84		-
85		-:- func init = runtime.
86		-
87		-%-----------------------------------------------------------------------------%
88		-
89		-:- pred push_stack_frame(runtime::in, runtime::out) is det.
90		-
91		-%-----------------------------------------------------------------------------%
92		-
93		-:- pred push_stack_frame(assoc_list.assoc_list(string, element)::in,
94		- runtime::in, runtime::out) is det.
95		-
96		-%-----------------------------------------------------------------------------%
97		-
98		-:- pred pop_stack_frame(runtime::in, runtime::out) is det.
99		-
100		-%-----------------------------------------------------------------------------%
101		-
102		-:- pred push_stack_frame_check(int::out, runtime::in, runtime::out) is det.
103		-
104		-%-----------------------------------------------------------------------------%
105		-
106		-:- pred push_stack_frame_check(assoc_list.assoc_list(string, element)::in,
107		- int::out, runtime::in, runtime::out) is det.
108		-
109		-%-----------------------------------------------------------------------------%
110		-
111		-:- pred pop_stack_frame_check(int::in, runtime::in, runtime::out) is det.
112		-
113		-%-----------------------------------------------------------------------------%
114		-
115		-:- pred def_var(string::in, element::in, runtime::in, runtime::out) is det.
116		-
117		-%-----------------------------------------------------------------------------%
118		-
119		-:- pred find_var(list.list(frame), rbtree.rbtree(string, element), string, element).
120		-:- mode find_var(in, in, in, out) is semidet.
121		-
122		-%-----------------------------------------------------------------------------%
123		-
124		-:- pred builtin_bind(bind_spec::in, bind::out) is semidet.
125		-
126		-%-----------------------------------------------------------------------------%
127		-
128		-:- pred def_bind(bind_spec::in, bind::in, runtime::in, runtime::out) is det.
129		-
130		-%-----------------------------------------------------------------------------%
131		-
132		-:- pred find_bind(string, int, rbtree.rbtree(bind_spec, bind), bind).
133		-:- mode find_bind(in, in, in, out) is semidet.
134		-
135		-%-----------------------------------------------------------------------------%
136		-% This is a workaround, as the Mercury compiler gets confused when disjuncting
137		-% on functors which contain predicates as elements in the functor.
138		-:- pred call_bind(bind, list.list(element), result, runtime, runtime).
139		-:- mode call_bind(in, in, res_uo, in, out) is det.
140		-
141		-%-----------------------------------------------------------------------------%
142		-
143		-:- type run_pred1 == (pred(element, result, runtime, runtime)).
144		-:- inst run_pred1 == (pred(in, res_uo, in, out) is det).
145		-:- mode run_pred1 == (pred(in, res_uo, in, out) is det).
146		-
147		-%-----------------------------------------------------------------------------%
148		-% Same as run_pred1, but is suitable for use with list.map_foldl2
149		-:- type run_pred2 == (pred(element, element,
150		- runtime, runtime,
151		- maybe.maybe_error, maybe.maybe_error)).
152		-:- inst run_pred2 == (pred(in, out, in, out, di, uo) is det).
153		-:- mode run_pred2 == (pred(in, out, in, out, di, uo) is det).
154		-
155		-%-----------------------------------------------------------------------------%
156		-% Same as run_pred1, but is suitable for use with list.map_foldl3 while
157		-% counting elements in the list.
158		-:- type run_pred3 == (pred(element, element,
159		- runtime, runtime,
160		- int, int,
161		- maybe.maybe_error, maybe.maybe_error)).
162		-:- inst run_pred3 == (pred(in, out, in, out, in, out, di, uo) is det).
163		-:- mode run_pred3 == (pred(in, out, in, out, in, out, di, uo) is det).
164		-
165		-%-----------------------------------------------------------------------------%
166		-
167		-:- pred reduce `with_type` run_pred1 `with_inst` run_pred1.
168		-:- pred reduce `with_type` run_pred2 `with_inst` run_pred2.
169		-:- pred reduce `with_type` run_pred3 `with_inst` run_pred3.
170		-
171		-%-----------------------------------------------------------------------------%
172		-
173		-:- pred execute `with_type` run_pred1 `with_inst` run_pred1.
174		-:- pred execute `with_type` run_pred2 `with_inst` run_pred2.
175		-:- pred execute `with_type` run_pred3 `with_inst` run_pred3.
176		-
177		-%=============================================================================%
178		-:- implementation.
179		-%=============================================================================%
180		-
181		-:- use_module exception.
182		-:- use_module int.
183		-:- use_module string.
184		-:- use_module pair.
185		-
186		-:- include_module tl_runtime.builtin.
187		-:- use_module tl_runtime.builtin.
188		-
189		-%-----------------------------------------------------------------------------%
190		-
191		-nil = list([]).
192		-
193		-%-----------------------------------------------------------------------------%
194		-% Used for the optimized C routines.
195		-:- pragma foreign_decl("C", "
196		-#ifdef _MSC_VER
197		-
198		-#define TL_YIELD_ARITY(ARITY, DST, OUT) \\
199		- _ltoa_s((ARITY), (OUT), 77, 10); \\
200		- (OUT)[76] = 0; \\
201		- const MR_Integer DST = strnlen_s((OUT), 77)
202		-
203		-#else
204		-
205		-#define TL_YIELD_ARITY(ARITY, DST, OUT) \\
206		- const MR_Integer DST = sprintf((OUT), ""%i"", (ARITY))
207		-
208		-#endif
209		-
210		-#define TL_YIELD_FUNC_NAME(NAME, NAME_LEN, ARITY, END, OUT) do { \\
211		- (OUT)[0] = '`'; \\
212		- memcpy((OUT)+1, Name, (NAME_LEN)); \\
213		- (OUT)[(NAME_LEN)+1] = '/'; \\
214		- { \\
215		- const MR_Integer arity_start = (NAME_LEN)+2; \\
216		- TL_YIELD_ARITY((ARITY), ZZ_end, (OUT) + arity_start) + arity_start; \\
217		- (OUT)[ZZ_end] = '`'; \\
218		- (END) = ZZ_end+1; \\
219		- } \\
220		- \\
221		-}while(0)
222		-
223		-").
224		-
225		-%-----------------------------------------------------------------------------%
226		-
227		-:- func yield_func_name(string::in, int::in) = (string::uo) is det.
228		-yield_func_name(Name, Arity) = string.append(TickFuncArity, "`") :-
229		- string.first_char(ArityString, ('/'), string.from_int(Arity)),
230		- string.first_char(TickFuncName, ('`'), Name),
231		- string.append(TickFuncName, ArityString, TickFuncArity).
232		-
233		-% Optimized C version.
234		-:- pragma foreign_proc("C", yield_func_name(Name::in, Arity::in) = (Out::uo),
235		- [promise_pure, thread_safe, will_not_call_mercury, will_not_modify_trail,
236		- does_not_affect_liveness, may_duplicate],
237		- "
238		- const MR_Integer name_len = strlen(Name);
239		- MR_allocate_aligned_string_msg(Out, name_len + 80, MR_ALLOC_ID);
240		- MR_Integer end;
241		- TL_YIELD_FUNC_NAME(Name, name_len, Arity, end, Out);
242		- Out[end] = 0;
243		- ").
244		-
245		-%-----------------------------------------------------------------------------%
246		-
247		-:- func func_error(string::in, int::in, string::in) = (string::uo) is det.
248		-func_error(Name, Arity, Error) =
249		- string.append(func_error_prefix(Name, Arity), Error).
250		-
251		-%-----------------------------------------------------------------------------%
252		-
253		-:- func func_error_prefix(string::in, int::in) = (string::uo) is det.
254		-func_error_prefix(Name, Arity) =
255		- string.append(
256		- string.append(
257		- "Error ",
258		- yield_func_name(Name, Arity)),
259		- " -> ").
260		-
261		-% Optimized C version.
262		-:- pragma foreign_proc("C", func_error(Name::in, Arity::in, Error::in) = (Out::uo),
263		- [promise_pure, thread_safe, will_not_call_mercury, will_not_modify_trail,
264		- does_not_affect_liveness, may_duplicate],
265		- "
266		- const char head[] = {'E', 'r', 'r', 'o', 'r', ':', ' '};
267		- const char tail[] = {' ', '-', '>', ' '};
268		- const MR_Integer name_len = strlen(Name);
269		- const MR_Integer error_len = strlen(Error);
270		- MR_allocate_aligned_string_msg(Out, name_len + error_len + 90, MR_ALLOC_ID);
271		- MR_Integer end;
272		- memcpy(Out, head, sizeof(head));
273		- TL_YIELD_FUNC_NAME(Name, name_len, Arity, end, Out+sizeof(head));
274		- memcpy(Out+sizeof(head)+end, tail, sizeof(tail));
275		- memcpy(Out+sizeof(head)+sizeof(tail)+end, Error, error_len+1);
276		- ").
277		-
278		-%-----------------------------------------------------------------------------%
279		-
280		-:- func list_index_error(int::in, int::in) = (string::uo) is det.
281		-list_index_error(At, Length) = Result :-
282		- string.append("`at` -> index of '", string.from_int(At), Err0),
283		- string.append(Err0, "' out of bounds for list of length '", Err1),
284		- string.append(Err1, string.from_int(Length), Err2),
285		- string.append(Err2, "'", Result).
286		-
287		-% Optimized C version.
288		-:- pragma foreign_proc("C", list_index_error(At::in, Length::in) = (Out::uo),
289		- [promise_pure, thread_safe, will_not_call_mercury, will_not_modify_trail,
290		- does_not_affect_liveness, may_duplicate],
291		- "
292		- MR_allocate_aligned_string_msg(Out, 160, MR_ALLOC_ID);
293		- snprintf(Out, 159,
294		- ""`at` -> index of '%i' out of bounds for list of length '%i'"",
295		- At, Length);
296		- Out[159] = 0;
297		- ").
298		-
299		-%-----------------------------------------------------------------------------%
300		-
301		-init_frame(Variables) = frame(Variables).
302		-init_frame = init_frame([]).
303		-
304		-%-----------------------------------------------------------------------------%
305		-
306		-init = runtime(rbtree.init, rbtree.init, [], []).
307		-
308		-%-----------------------------------------------------------------------------%
309		-
310		-push_stack_frame(Variables, runtime(G, B, Frames, PIO),
311		- runtime(G, B, [init_frame(Variables)\|Frames], PIO)).
312		-
313		-%-----------------------------------------------------------------------------%
314		-
315		-push_stack_frame(runtime(G, B, Frames, PIO),
316		- runtime(G, B, [init_frame\|Frames], PIO)).
317		-
318		-%-----------------------------------------------------------------------------%
319		-
320		-pop_stack_frame(runtime(G, B, [_Head\|Frames], PIO),
321		- runtime(G, B, Frames, PIO)) :-
322		- % trace [io(!IO)] (
323		- % rbtree.keys(Head ^ variables, Keys),
324		- % io.write_string("Pop losing ", !IO),
325		- % io.write_int(list.length(Keys), !IO), io.nl(!IO),
326		- % list.foldl(
327		- % (pred(Str::in, I::di, O::uo) is semidet :-
328		- % io.write_string(Str, I, M), io.nl(M, O)),
329		- % Keys, !IO)
330		- % ),
331		- true.
332		-
333		-pop_stack_frame(runtime(_, _, [], _), _) :-
334		- exception.throw(exception.software_error("Stack underflow")).
335		-
336		-%-----------------------------------------------------------------------------%
337		-
338		-push_stack_frame_check(Check, !Runtime) :-
339		- push_stack_frame(!Runtime),
340		- list.length(!.Runtime ^ stack_frames, Check).
341		-
342		-%-----------------------------------------------------------------------------%
343		-
344		-push_stack_frame_check(Variables, Check, !Runtime) :-
345		- push_stack_frame(Variables, !Runtime),
346		- list.length(!.Runtime ^ stack_frames, Check).
347		-
348		-%-----------------------------------------------------------------------------%
349		-
350		-pop_stack_frame_check(Check, !Runtime) :-
351		- ( if
352		- list.length(!.Runtime ^ stack_frames, Check)
353		- then
354		- pop_stack_frame(!Runtime)
355		- else
356		- exception.throw(exception.software_error("Stack mismatch"))
357		- ).
358		-
359		-%-----------------------------------------------------------------------------%
360		-
361		-def_var(Name, Value, !Runtime) :-
362		- !.Runtime ^ stack_frames = StackFrames,
363		- (
364		- StackFrames = [frame(In)\|Tail],
365		-
366		- ( assoc_list.remove(In, Name, _, V) -> Out = V ; Out = In ),
367		-
368		- !Runtime ^ stack_frames := [frame([pair.pair(Name, Value)\|Out])\|Tail]
369		- ;
370		- StackFrames = [],
371		-
372		- !.Runtime ^ globals = In,
373		- rbtree.set(Name, Value, In, Out),
374		- !Runtime ^ globals := Out
375		- ).
376		-
377		-%-----------------------------------------------------------------------------%
378		-
379		-find_var([], Globals, Name, Value) :- rbtree.search(Globals, Name, Value).
380		-find_var([frame(Head)\|Tail], Globals, Name, Value) :-
381		- ( if
382		- assoc_list.search(Head, Name, SemiValue)
383		- then
384		- Value = SemiValue
385		- else
386		- find_var(Tail, Globals, Name, Value)
387		- ).
388		-
389		-%-----------------------------------------------------------------------------%
390		-
391		-builtin_bind(args("=", 4), mercury_bind(tl_runtime__builtin__builtin_eq_bind)).
392		-builtin_bind(args("!", 4), mercury_bind(tl_runtime__builtin__builtin_ne_bind)).
393		-builtin_bind(args("<", 4), mercury_bind(tl_runtime__builtin__builtin_lt_bind)).
394		-builtin_bind(args(">", 4), mercury_bind(tl_runtime__builtin__builtin_gt_bind)).
395		-builtin_bind(args("<=", 4), mercury_bind(tl_runtime__builtin__builtin_le_bind)).
396		-builtin_bind(args(">=", 4), mercury_bind(tl_runtime__builtin__builtin_ge_bind)).
397		-
398		-builtin_bind(args("+", 2), mercury_bind(tl_runtime__builtin__builtin_plus_bind)).
399		-builtin_bind(args("-", 2), mercury_bind(tl_runtime__builtin__builtin_minus_bind)).
400		-builtin_bind(args("*", 2), mercury_bind(tl_runtime__builtin__builtin_times_bind)).
401		-builtin_bind(args("/", 2), mercury_bind(tl_runtime__builtin__builtin_divide_bind)).
402		-
403		-builtin_bind(args("fn", 3), mercury_bind(tl_runtime__builtin__builtin_fn_bind)).
404		-
405		-%-----------------------------------------------------------------------------%
406		-
407		-def_bind(BindSpec, Bind, !Runtime) :-
408		- Binds = !.Runtime ^ binds,
409		- !Runtime ^ binds := rbtree.set(Binds, BindSpec, Bind).
410		-
411		-%-----------------------------------------------------------------------------%
412		-
413		-find_bind(Name, Arity, Tree, Out) :-
414		- % Try for set args before trying for variadic args.
415		- Args = args(Name, Arity), Variadic = variadic(Name),
416		- ( if
417		- rbtree.search(Tree, Args, Bind)
418		- then
419		- Out = Bind
420		- else if
421		- builtin_bind(Args, Bind)
422		- then
423		- Out = Bind
424		- else if
425		- rbtree.search(Tree, Variadic, Bind)
426		- then
427		- Out = Bind
428		- else
429		- builtin_bind(Variadic, Out)
430		- ).
431		-
432		-%-----------------------------------------------------------------------------%
433		-
434		-call_bind(mercury_bind(Pred), Args, Result, !Runtime) :-
435		- call(Pred, Args, Result:result, !Runtime).
436		-
437		-call_bind(lisp_bind(ArgNames, Body), Args, Result, !Runtime) :-
438		-
439		- assoc_list.from_corresponding_lists(ArgNames, Args, Variables),
440		-
441		- % This is needed both for a func call, and just to yield the reduced
442		- % version of this list if it is not executable.
443		- push_stack_frame_check(Variables, Check, !Runtime),
444		- % trace [io(!IO)] ( io.write_string("Push stack from in call_bind\n", !IO) ),
445		-
446		- list.map_foldl2(execute, Body, Values, !Runtime, maybe.ok, CallResult),
447		-
448		- % trace [io(!IO)] ( io.write_string("Pop stack from in call_bind\n", !IO) ),
449		- pop_stack_frame_check(Check, !Runtime),
450		-
451		- (
452		- CallResult = maybe.ok,
453		- ( if
454		- list.last(Values, Last)
455		- then
456		- Result = maybe.ok(Last)
457		- else
458		- Result = maybe.ok(nil)
459		- )
460		- ;
461		- CallResult = maybe.error(Error),
462		- Result = maybe.error(Error)
463		- ).
464		-
465		-%-----------------------------------------------------------------------------%
466		-% Result of preprocessing.
467		-% Comparison is a special case because of laziness.
468		-:- type preprocess_result --->
469		- reduced(element) ; % Result is fully reduced.
470		- execute(string, list(element), preprocess_arity::int) ; % Result is a call.
471		- comparison(tl_runtime.builtin.comparison, element, element, list(element)).
472		-
473		-%-----------------------------------------------------------------------------%
474		-% Performs preprocessing logic which is shared between reduce and execute.
475		-:- pred preprocess(run_pred3, element, maybe.maybe_error(preprocess_result), runtime, runtime).
476		-:- mode preprocess(run_pred3, in, res_uo, in, out) is det.
477		-
478		-% Pass atoms through unchanged.
479		-preprocess(_, atom(Str), maybe.ok(reduced(atom(Str))), !Runtime).
480		-
481		-% Empty list, nothing to do.
482		-preprocess(_, list([]), maybe.ok(reduced(list([]))), !Runtime).
483		-
484		-% Do a maybe-reduce on a list with a list as its head.
485		-preprocess(Pred, list(ElementsRaw @ [list(_)\|_]), Result, !Runtime) :-
486		- list.map_foldl3(Pred, ElementsRaw, Elements,
487		- !Runtime,
488		- 0, ArgNum,
489		- maybe.ok, ElementsError),
490		- (
491		- ElementsError = maybe.error(Error),
492		- Result = maybe.error(Error)
493		- ;
494		- ElementsError = maybe.ok,
495		- (
496		- ( Elements = [] ; Elements = [list(_)\|_] ),
497		- Result = maybe.ok(reduced(list(Elements)))
498		- ;
499		- Elements = [atom(Tag)\|Tail],
500		- Result = maybe.ok(execute(Tag, Tail, ArgNum))
501		- )
502		- ).
503		-
504		-% Report a call for a list consisting of just an atom.
505		-preprocess(_, list([atom(Tag)\|[]]), maybe.ok(execute(Tag, [], 0)), !Runtime).
506		-
507		-% Do a maybe-reduce on a list with an atom as its head.
508		-preprocess(Pred, In @ list([atom(Tag)\|Tail]), Result, !Runtime) :-
509		- Tail = [_\|_],
510		- ( if
511		- Tag = "."
512		- then
513		- % Escaped list.
514		- Result = maybe.ok(reduced(In))
515		- else if
516		- % Special handling for comparisons, since they must be laziy evaluated.
517		- tl_runtime.builtin.builtin_op_tag(Op, Tag),
518		- tl_runtime.builtin.comparison(Cmp) = Op
519		- then
520		- % Sort of punt on argument lists less than size 2.
521		- % These will be errors later anyway.
522		- (
523		- Tail = [_\|[]],
524		- Result = maybe.ok(execute(Tag, Tail, 1))
525		- ;
526		- [E1\|[E2\|Tail2]] = Tail,
527		- Pred(E1, R1, !Runtime, 0, _, maybe.ok, ResultMid),
528		- Pred(E2, R2, !Runtime, 0, _, ResultMid, PredResult),
529		- (
530		- PredResult = maybe.ok,
531		- Result = maybe.ok(comparison(Cmp, R1, R2, Tail2))
532		- ;
533		- PredResult = maybe.error(Error),
534		- Result = maybe.error(Error)
535		- )
536		- )
537		- else
538		- list.map_foldl3(Pred, Tail, ReducedTail,
539		- !Runtime,
540		- 0, ArgNum,
541		- maybe.ok, ElementsError),
542		- (
543		- ElementsError = maybe.error(Error),
544		- Result = maybe.error(Error)
545		- ;
546		- ElementsError = maybe.ok,
547		- Result = maybe.ok(execute(Tag, ReducedTail, ArgNum))
548		- )
549		- ).
550		-
551		-%-----------------------------------------------------------------------------%
552		-
553		-:- pred is_atom(element).
554		-:- mode is_atom(in) is semidet.
555		-
556		-is_atom(atom(_)).
557		-
558		-%-----------------------------------------------------------------------------%
559		-
560		-:- pred is_atom_or_list_of_atoms(element).
561		-:- mode is_atom_or_list_of_atoms(in) is semidet.
562		-
563		-is_atom_or_list_of_atoms(atom(_)).
564		-is_atom_or_list_of_atoms(list([])).
565		-is_atom_or_list_of_atoms(list(List @ [_\|_])) :- list.all_true(is_atom, List).
566		-
567		-%-----------------------------------------------------------------------------%
568		-% Reduces an element. This is mainly different in how it handles results from
569		-% binds, and how it handles comparisons.
570		-reduce(Element, Result, !Runtime) :-
571		- preprocess(reduce, Element, PreprocessResult, !Runtime),
572		- (
573		- PreprocessResult = maybe.error(Error),
574		- Result = maybe.error(Error)
575		- ;
576		- PreprocessResult = maybe.ok(PreprocessOutput),
577		- (
578		- PreprocessOutput = reduced(Reduced),
579		- Result = maybe.ok(Reduced)
580		- ;
581		- PreprocessOutput = comparison(Cmp, A, B, Tail),
582		-
583		- % Try to inline the result of the comparison, if possible.
584		- % This also allows us to not even compile the side which was not used.
585		- tl_runtime.builtin.comparison_tag(Cmp, Tag),
586		- FallbackResult = maybe.ok(list([atom(Tag)\|Tail])),
587		- (
588		- % Incorrect tail length for comparison builtin. Good luck kid.
589		- ( Tail = [] ; Tail = [_\|[]] ; Tail = [_\|[_\|[_\|_]]] ),
590		- Result = FallbackResult
591		- ;
592		- Tail = [Y\|[N\|[]]],
593		- tl_runtime.builtin.comparison(Cmp, A, B, CmpResult),
594		- (
595		- CmpResult = tl_runtime.builtin.error(_),
596		- Result = FallbackResult
597		- ;
598		- (
599		- CmpResult = tl_runtime.builtin.yes, Choice = Y
600		- ;
601		- CmpResult = tl_runtime.builtin.no, Choice = N
602		- ),
603		-
604		- % It should be safe to reduce the result. EIther it is known at
605		- % compile-time, or the comparison will have failed to yield a
606		- % result and we won't be in this arm.
607		- reduce(Choice, ChoiceResult, !Runtime),
608		- (
609		- ChoiceResult = maybe.error(_),
610		- Result = FallbackResult
611		- ;
612		- ChoiceResult = maybe.ok(_),
613		- Result = ChoiceResult
614		- )
615		- )
616		- )
617		- ;
618		- PreprocessOutput = execute(Tag, Tail, Arity),
619		- ( if
620		- % Do NOT use the results of define ops during reduction.
621		- % For let's, the existence of the let will be erased by popping
622		- % the stack frame, and the value will not show up later in the
623		- % actual execution.
624		- % For fn's def's, this would erase the definition entirely as
625		- % we may lose the entire runtime between reduction and
626		- % execution (as in copmilation model).
627		- % We can still retain the reduced tail, however.
628		- % It is also useful to actually bind the value anyway, since
629		- % this lets us inline functions and variables.
630		- % See below for inlining determination.
631		- tl_runtime__builtin__builtin_op_tag(
632		- tl_runtime__builtin__define(Op), Tag)
633		- then
634		- (
635		- Op = tl_runtime__builtin__fn,
636		- % Super rudimentary inline test.
637		- % Only inline fn if we have a body consisting of less than
638		- % 64 elements, and all the elements are either atoms or a
639		- % list of atoms (as opposed to a list with list elements).
640		- ( if
641		- list.index0(Tail, 1, Body),
642		- (
643		- Body = atom(_)
644		- ;
645		- Body = list(List),
646		- builtin__compare((<), list.length(List), 64),
647		- list.all_true(is_atom_or_list_of_atoms, List)
648		- )
649		- then
650		- tl_runtime__builtin__builtin_fn_bind(Tail, _, !Runtime)
651		- else
652		- true
653		- )
654		- ;
655		- Op = tl_runtime__builtin__let
656		- ;
657		- Op = tl_runtime__builtin__def
658		- ),
659		- Result = maybe.ok(list([atom(Tag)\|Tail]))
660		- else if
661		- find_bind(Tag, Arity, !.Runtime ^ binds, Bind)
662		- then
663		- call_bind(Bind, Tail, CallResult, !Runtime),
664		-
665		- (
666		- CallResult = maybe.error(Error),
667		- Result = maybe.error(func_error(Tag, Arity, Error))
668		- ;
669		- CallResult = maybe.ok(_),
670		- Result = CallResult
671		- )
672		- else
673		- Result = maybe.ok(list([atom(Tag)\|Tail]))
674		- )
675		- )
676		- ).
677		-
678		-%-----------------------------------------------------------------------------%
679		-
680		-reduce(!E, !R, maybe.error(E), maybe.error(E)).
681		-reduce(In, Out, !Runtime, maybe.ok, Result) :-
682		- reduce(In, OutResult, !Runtime),
683		- (
684		- OutResult = maybe.error(Error),
685		- Result = maybe.error(Error),
686		- In = Out
687		- ;
688		- OutResult = maybe.ok(Out),
689		- Result = maybe.ok
690		- ).
691		-
692		-%-----------------------------------------------------------------------------%
693		-
694		-reduce(!Element, !Runtime, N, int.plus(N, 1), !Error) :-
695		- reduce(!Element, !Runtime, !Error).
696		-
697		-%-----------------------------------------------------------------------------%
698		-
699		-execute(Element, Result, !Runtime) :-
700		- preprocess(reduce, Element, PreprocessResult, !Runtime),
701		- (
702		- PreprocessResult = maybe.error(Error),
703		- Result = maybe.error(Error)
704		- ;
705		- PreprocessResult = maybe.ok(PreprocessOutput),
706		- (
707		- PreprocessOutput = reduced(list(ReducedList)),
708		- % Remove escaping during execution.
709		- ( if
710		- ReducedList = [atom(".")\|Tail]
711		- then
712		- Result = maybe.ok(list(Tail))
713		- else
714		- Result = maybe.ok(list(ReducedList))
715		- )
716		- ;
717		- PreprocessOutput = reduced(atom(ReducedAtom)),
718		- ( if
719		- find_var(!.Runtime ^ stack_frames,
720		- !.Runtime ^ globals,
721		- ReducedAtom, SemiValue)
722		- then
723		- Result = maybe.ok(SemiValue)
724		- else
725		- Result = maybe.ok(atom(ReducedAtom))
726		- )
727		- ;
728		- PreprocessOutput = comparison(Cmp, A, B, Tail),
729		-
730		- (
731		- % Incorrect tail length for comparison builtin. Good luck kid.
732		- ( Tail = [] ; Tail = [_\|[]] ; Tail = [_\|[_\|[_\|_]]] ),
733		- tl_runtime.builtin.comparison_tag(Cmp, Tag),
734		- Result = maybe.error(func_error(Tag, 2, "Comparison must have arity of 2"))
735		- ;
736		- Tail = [Y\|[N\|[]]],
737		- tl_runtime.builtin.comparison(Cmp, A, B, CmpResult),
738		- (
739		- CmpResult = tl_runtime.builtin.error(Error),
740		- tl_runtime.builtin.comparison_tag(Cmp, Tag),
741		- Result = maybe.error(func_error(Tag, 2, Error))
742		- ;
743		- (
744		- CmpResult = tl_runtime.builtin.yes, Choice = Y
745		- ;
746		- CmpResult = tl_runtime.builtin.no, Choice = N
747		- ),
748		-
749		- % It should be safe to reduce the result. EIther it is known at
750		- % compile-time, or the comparison will have failed to yield a
751		- % result and we won't be in this arm.
752		- reduce(Choice, ChoiceResult, !Runtime),
753		- (
754		- ChoiceResult = maybe.error(Error),
755		- tl_runtime.builtin.comparison_tag(Cmp, Tag),
756		- Result = maybe.error(func_error(Tag, 2, Error))
757		- ;
758		- ChoiceResult = maybe.ok(_),
759		- Result = ChoiceResult
760		- )
761		- )
762		- )
763		- ;
764		- PreprocessOutput = execute(Tag, Tail, Arity),
765		-
766		- ( if
767		- find_bind(Tag, Arity, !.Runtime ^ binds, Bind)
768		- then
769		- call_bind(Bind, Tail, CallResult, !Runtime),
770		- (
771		- CallResult = maybe.error(Error),
772		- Result = maybe.error(func_error(Tag, Arity, Error))
773		- ;
774		- CallResult = maybe.ok(_),
775		- Result = CallResult
776		- )
777		- else
778		- Result = maybe.ok(list([atom(Tag)\|Tail]))
779		- )
780		- )
781		- ).
782		-
783		-%-----------------------------------------------------------------------------%
784		-
785		-execute(!E, !R, maybe.error(E), maybe.error(E)).
786		-execute(In, Out, !Runtime, maybe.ok, Result) :-
787		- execute(In, OutResult, !Runtime),
788		- (
789		- OutResult = maybe.error(Error),
790		- Result = maybe.error(Error),
791		- In = Out
792		- ;
793		- OutResult = maybe.ok(Out),
794		- Result = maybe.ok
795		- ).
796		-
797		-%-----------------------------------------------------------------------------%
798		-
799		-execute(!Element, !Runtime, N, int.plus(N, 1), !Error) :-
800		- execute(!Element, !Runtime, !Error).
		\ No newline at end of file

turbolisp Fork

Commit

Tags

Frequently used words (click to add to your profile)

Commit MetaInfo

Log Message

Change Summary

Incremental Difference

turbolisp
Fork