• R/O
  • HTTP
  • SSH
  • HTTPS

Commit

Frequently used words (click to add to your profile)

javaandroidc++linuxc#objective-ccocoa誰得qtrubypythonwindowsphpgamebathyscaphegui翻訳comegattwitterframeworkbtronvb.net計画中(planning stage)testdomarduinodirectxpreviewerゲームエンジン

A small standalone Lisp used as a scripting language in the Z2 game engine


Commit MetaInfo

Revisionbbe281179bed7d4ec2e9f102648a12ebd87d631e (tree)
Zeit2019-07-28 06:29:30
AutorAlaskanEmily <emily@alas...>
CommiterAlaskanEmily

Log Message

Remove modules which were supposed to be renamed

Ändern Zusammenfassung

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

Diff

--- 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