• R/O
  • HTTP
  • SSH
  • HTTPS

Commit

Frequently used words (click to add to your profile)

javac++androidlinuxc#windowsobjective-ccocoa誰得qtpythonphprubygameguibathyscaphec計画中(planning stage)翻訳omegatframeworktwitterdomtestvb.netdirectxゲームエンジンbtronarduinopreviewer

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


Commit MetaInfo

Revisão4b3a1764418e682332f903c5d4797fa370476a47 (tree)
Hora2019-11-10 05:10:50
AutorAlaskanEmily <emily@alas...>
CommiterAlaskanEmily

Mensagem de Log

Fix line endings

Mudança Sumário

Diff

--- a/turbo_s.m
+++ b/turbo_s.m
@@ -1,87 +1,87 @@
1-% Any copyright is dedicated to the Public Domain.
2-% http://creativecommons.org/publicdomain/zero/1.0/
3-
4-:- module turbo_s.
5-
6-%=============================================================================%
7-% S-expression parser for TurboLisp
8-:- interface.
9-%=============================================================================%
10-
11-:- use_module io.
12-:- import_module list.
13-:- use_module maybe.
14-
15-:- include_module turbo_s.parser.
16-:- include_module turbo_s.string_stream.
17-
18-:- use_module turbo_s.string_stream.
19-
20-%-----------------------------------------------------------------------------%
21-
22-:- type element ---> atom(string) ; list(list.list(element)).
23-
24-%-----------------------------------------------------------------------------%
25-
26-:- pred parse(io.text_input_stream, list.list(element), io.res(list.list(element)), io.io, io.io).
27-:- mode parse(in, in, out, di, uo) is det.
28-
29-%-----------------------------------------------------------------------------%
30-
31-:- pred parse_string_stream(string,
32- list.list(element),
33- turbo_s.string_stream.string_range,
34- maybe.maybe_error(list.list(element))).
35-:- mode parse_string_stream(in, in, di, out) is det.
36-
37-%=============================================================================%
38-:- implementation.
39-%=============================================================================%
40-
41-:- use_module stream.
42-
43-:- use_module turbo_s.parser.
44-
45-%-----------------------------------------------------------------------------%
46-
47-:- func ss_errors = turbo_s.parser.errors(turbo_s.string_stream.error).
48-ss_errors = turbo_s.parser.errors(
49- turbo_s.string_stream.error("Unexpected EOF"),
50- turbo_s.string_stream.error("Unmatched close paren")).
51-
52-%-----------------------------------------------------------------------------%
53-
54-parse_string_stream(String, List, StringRangeIn, Result) :-
55- turbo_s.parser.parse(String, ss_errors, ElementResult, StringRangeIn, StringRangeOut),
56- (
57- ElementResult = stream.ok(Element),
58- parse_string_stream(String, [Element|List], StringRangeOut, Result)
59- ;
60- ElementResult = stream.eof,
61- Result = maybe.ok(list.reverse(List))
62- ;
63- ElementResult = stream.error(turbo_s.string_stream.error(E)),
64- Result = maybe.error(E)
65- ).
66-
67-%-----------------------------------------------------------------------------%
68-
69-:- func io_errors = turbo_s.parser.errors(io.error).
70-io_errors = turbo_s.parser.errors(
71- io.make_io_error("Unexpected EOF"),
72- io.make_io_error("Unmatched close paren")).
73-
74-%-----------------------------------------------------------------------------%
75-
76-parse(Stream, List, Result, !IO) :-
77- turbo_s.parser.parse(Stream, io_errors, ElementResult, !IO),
78- (
79- ElementResult = stream.ok(Element),
80- parse(Stream, [Element|List], Result, !IO)
81- ;
82- ElementResult = stream.eof,
83- Result = io.ok(list.reverse(List))
84- ;
85- ElementResult = stream.error(E),
86- Result = io.error(E)
1+% Any copyright is dedicated to the Public Domain.
2+% http://creativecommons.org/publicdomain/zero/1.0/
3+
4+:- module turbo_s.
5+
6+%=============================================================================%
7+% S-expression parser for TurboLisp
8+:- interface.
9+%=============================================================================%
10+
11+:- use_module io.
12+:- import_module list.
13+:- use_module maybe.
14+
15+:- include_module turbo_s.parser.
16+:- include_module turbo_s.string_stream.
17+
18+:- use_module turbo_s.string_stream.
19+
20+%-----------------------------------------------------------------------------%
21+
22+:- type element ---> atom(string) ; list(list.list(element)).
23+
24+%-----------------------------------------------------------------------------%
25+
26+:- pred parse(io.text_input_stream, list.list(element), io.res(list.list(element)), io.io, io.io).
27+:- mode parse(in, in, out, di, uo) is det.
28+
29+%-----------------------------------------------------------------------------%
30+
31+:- pred parse_string_stream(string,
32+ list.list(element),
33+ turbo_s.string_stream.string_range,
34+ maybe.maybe_error(list.list(element))).
35+:- mode parse_string_stream(in, in, di, out) is det.
36+
37+%=============================================================================%
38+:- implementation.
39+%=============================================================================%
40+
41+:- use_module stream.
42+
43+:- use_module turbo_s.parser.
44+
45+%-----------------------------------------------------------------------------%
46+
47+:- func ss_errors = turbo_s.parser.errors(turbo_s.string_stream.error).
48+ss_errors = turbo_s.parser.errors(
49+ turbo_s.string_stream.error("Unexpected EOF"),
50+ turbo_s.string_stream.error("Unmatched close paren")).
51+
52+%-----------------------------------------------------------------------------%
53+
54+parse_string_stream(String, List, StringRangeIn, Result) :-
55+ turbo_s.parser.parse(String, ss_errors, ElementResult, StringRangeIn, StringRangeOut),
56+ (
57+ ElementResult = stream.ok(Element),
58+ parse_string_stream(String, [Element|List], StringRangeOut, Result)
59+ ;
60+ ElementResult = stream.eof,
61+ Result = maybe.ok(list.reverse(List))
62+ ;
63+ ElementResult = stream.error(turbo_s.string_stream.error(E)),
64+ Result = maybe.error(E)
65+ ).
66+
67+%-----------------------------------------------------------------------------%
68+
69+:- func io_errors = turbo_s.parser.errors(io.error).
70+io_errors = turbo_s.parser.errors(
71+ io.make_io_error("Unexpected EOF"),
72+ io.make_io_error("Unmatched close paren")).
73+
74+%-----------------------------------------------------------------------------%
75+
76+parse(Stream, List, Result, !IO) :-
77+ turbo_s.parser.parse(Stream, io_errors, ElementResult, !IO),
78+ (
79+ ElementResult = stream.ok(Element),
80+ parse(Stream, [Element|List], Result, !IO)
81+ ;
82+ ElementResult = stream.eof,
83+ Result = io.ok(list.reverse(List))
84+ ;
85+ ElementResult = stream.error(E),
86+ Result = io.error(E)
8787 ).
\ No newline at end of file
--- a/turbolisp.runtime.builtin.arithmetic.m
+++ b/turbolisp.runtime.builtin.arithmetic.m
@@ -1,170 +1,170 @@
1-% Copyright (c) 2019 AlaskanEmily, Transnat Games
2-%
3-% This Source Code Form is subject to the terms of the Mozilla Public
4-% License, v. 2.0. If a copy of the MPL was not distributed with this
5-% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6-
7-:- module turbolisp.runtime.builtin.arithmetic.
8-
9-%=============================================================================%
10-% TurboLisp implementation details for arithmetic builtins.
11-:- interface.
12-%=============================================================================%
13-
14-:- func int_to_float(int::in) = (float::uo) is det.
15-
16-%-----------------------------------------------------------------------------%
17-
18-:- func inc(int) = int.
19-
20-%-----------------------------------------------------------------------------%
21-
22-:- type math_pred == (pred(number, number, string)).
23-:- mode math_pred == (pred(in, in, uo) is det).
24-:- inst math_pred == (pred(in, in, uo) is det).
25-
26-%-----------------------------------------------------------------------------%
27-% TODO: Variadic + and *?
28-:- pred builtin_plus `with_type` math_pred `with_inst` math_pred.
29-:- pred builtin_minus `with_type` math_pred `with_inst` math_pred.
30-:- pred builtin_times `with_type` math_pred `with_inst` math_pred.
31-:- pred builtin_divide `with_type` math_pred `with_inst` math_pred.
32-
33-%-----------------------------------------------------------------------------%
34-
35-:- pred builtin_arithmetic_bind(math_pred, arithmetic, list(element), result).
36-:- mode builtin_arithmetic_bind(math_pred, in, in, res_uo) is det.
37-
38-%=============================================================================%
39-% Most of the implementation of the arithmetic submodule is private.
40-:- implementation.
41-%=============================================================================%
42-
43-:- use_module int.
44-:- import_module float.
45-
46-%-----------------------------------------------------------------------------%
47-
48-:- pragma inline(int_to_float/1).
49-
50-%-----------------------------------------------------------------------------%
51-
52-int_to_float(I) = ((0.0)+float(I)).
53-
54-%-----------------------------------------------------------------------------%
55-
56-inc(I) = int.plus(I, 1).
57-
58-%-----------------------------------------------------------------------------%
59-
60-:- func float_plus(float::in, float::in) = (float::uo) is det.
61-:- func float_minus(float::in, float::in) = (float::uo) is det.
62-:- func float_times(float::in, float::in) = (float::uo) is det.
63-:- func float_divide(float::in, float::in) = (float::uo) is det.
64-
65-float_plus(A, B) = (A+B).
66-float_minus(A, B) = (A-B).
67-float_times(A, B) = (A*B).
68-float_divide(A, B) = (A/B).
69-
70-%-----------------------------------------------------------------------------%
71-
72-:- pred two_atoms(element, element, maybe.maybe_error({string, string})).
73-:- mode two_atoms(in, in, out(maybe_unique_error)) is det.
74-
75-two_atoms(list(_), list(_), maybe.error("Args 1 and 2 not atoms")).
76-two_atoms(atom(_), list(_), maybe.error("Arg 2 not atom")).
77-two_atoms(list(_), atom(_), maybe.error("Arg 1 not atom")).
78-two_atoms(atom(A), atom(B), maybe.ok({A, B})).
79-
80-:- pragma inline(two_atoms/3).
81-
82-%-----------------------------------------------------------------------------%
83-
84-:- pred two_atoms(list.list(element), maybe.maybe_error({string, string})).
85-:- mode two_atoms(in, out(maybe_unique_error)) is det.
86-
87-:- pragma inline(two_atoms/2).
88-
89-two_atoms(Args, Result) :-
90- (
91- Args = [],
92- Result = maybe.error("no values")
93- ;
94- Args = [_|[]],
95- Result = maybe.error("not 2 values (1)")
96- ;
97- Args = [_|[_|[_|_]]],
98- Result = maybe.error(string.append(string.append(
99- "not 2 values (", string.from_int(list.length(Args))),
100- ")"))
101- ;
102- Args = [A|[B|[]]],
103- two_atoms(A, B, Result)
104- ).
105-
106-%-----------------------------------------------------------------------------%
107-
108-:- func arithmetic(func(int, int) = int, func(float, float) = float,
109- number, number) = (string).
110-:- mode arithmetic(func(in, in) = (out) is det, func(in, in) = (uo) is det,
111- in, in) = (uo) is det.
112-
113-arithmetic(Func, _, int(A), int(B)) = string.from_int(Func(A, B)).
114-arithmetic(_, Func, float(A), float(B)) = string.from_float(Func(A, B)).
115-arithmetic(_, Func, int(A), float(B)) = string.from_float(Func(float(A), B)).
116-arithmetic(_, Func, float(A), int(B)) = string.from_float(Func(A, float(B))).
117-
118-%-----------------------------------------------------------------------------%
119-
120-builtin_plus(ANum, BNum, arithmetic(int.plus, float_plus, ANum, BNum)).
121-builtin_minus(ANum, BNum, arithmetic(int.minus, float_minus, ANum, BNum)).
122-builtin_times(ANum, BNum, arithmetic(int.times, float_times, ANum, BNum)).
123-builtin_divide(ANum, BNum, arithmetic('int__div', float_divide, ANum, BNum)).
124-
125-%-----------------------------------------------------------------------------%
126-% Implementation of arithmetic operators.
127-:- pred arithmetic(math_pred,
128- arithmetic, list.list(element), result).
129-:- mode arithmetic(math_pred,
130- in, in, res_uo) is det.
131-
132-:- pragma inline(arithmetic/4).
133-
134-arithmetic(Pred, Op, Args, Result) :-
135- two_atoms(Args, ArgsResult),
136- (
137- ArgsResult = maybe.error(Error),
138- builtin_op_tag(arithmetic(Op), Tag),
139- Result = maybe.error(func_error(Tag, 2, Error))
140- ;
141- ArgsResult = maybe.ok({AStr, BStr}),
142- ( if
143- number_type(AStr, ANum)
144- then
145- ( if
146- number_type(BStr, BNum)
147- then
148- Pred(ANum, BNum, Out),
149- Result = maybe.ok(atom(Out))
150- else
151- builtin_op_tag(arithmetic(Op), Tag),
152- Result = maybe.error(func_error(
153- Tag,
154- 2,
155- string.append(string.append(
156- "arg 2 not a number (", BStr), ")")))
157- )
158- else
159- builtin_op_tag(arithmetic(Op), Tag),
160- Result = maybe.error(func_error(
161- Tag,
162- 2,
163- string.append(string.append(
164- "arg 1 not a number (", AStr), ")")))
165- )
166- ).
167-
168-%-----------------------------------------------------------------------------%
169-
170-builtin_arithmetic_bind(Pred, Op, Args, Out) :- arithmetic(Pred, Op, Args, Out).
1+% Copyright (c) 2019 AlaskanEmily, Transnat Games
2+%
3+% This Source Code Form is subject to the terms of the Mozilla Public
4+% License, v. 2.0. If a copy of the MPL was not distributed with this
5+% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6+
7+:- module turbolisp.runtime.builtin.arithmetic.
8+
9+%=============================================================================%
10+% TurboLisp implementation details for arithmetic builtins.
11+:- interface.
12+%=============================================================================%
13+
14+:- func int_to_float(int::in) = (float::uo) is det.
15+
16+%-----------------------------------------------------------------------------%
17+
18+:- func inc(int) = int.
19+
20+%-----------------------------------------------------------------------------%
21+
22+:- type math_pred == (pred(number, number, string)).
23+:- mode math_pred == (pred(in, in, uo) is det).
24+:- inst math_pred == (pred(in, in, uo) is det).
25+
26+%-----------------------------------------------------------------------------%
27+% TODO: Variadic + and *?
28+:- pred builtin_plus `with_type` math_pred `with_inst` math_pred.
29+:- pred builtin_minus `with_type` math_pred `with_inst` math_pred.
30+:- pred builtin_times `with_type` math_pred `with_inst` math_pred.
31+:- pred builtin_divide `with_type` math_pred `with_inst` math_pred.
32+
33+%-----------------------------------------------------------------------------%
34+
35+:- pred builtin_arithmetic_bind(math_pred, arithmetic, list(element), result).
36+:- mode builtin_arithmetic_bind(math_pred, in, in, res_uo) is det.
37+
38+%=============================================================================%
39+% Most of the implementation of the arithmetic submodule is private.
40+:- implementation.
41+%=============================================================================%
42+
43+:- use_module int.
44+:- import_module float.
45+
46+%-----------------------------------------------------------------------------%
47+
48+:- pragma inline(int_to_float/1).
49+
50+%-----------------------------------------------------------------------------%
51+
52+int_to_float(I) = ((0.0)+float(I)).
53+
54+%-----------------------------------------------------------------------------%
55+
56+inc(I) = int.plus(I, 1).
57+
58+%-----------------------------------------------------------------------------%
59+
60+:- func float_plus(float::in, float::in) = (float::uo) is det.
61+:- func float_minus(float::in, float::in) = (float::uo) is det.
62+:- func float_times(float::in, float::in) = (float::uo) is det.
63+:- func float_divide(float::in, float::in) = (float::uo) is det.
64+
65+float_plus(A, B) = (A+B).
66+float_minus(A, B) = (A-B).
67+float_times(A, B) = (A*B).
68+float_divide(A, B) = (A/B).
69+
70+%-----------------------------------------------------------------------------%
71+
72+:- pred two_atoms(element, element, maybe.maybe_error({string, string})).
73+:- mode two_atoms(in, in, out(maybe_unique_error)) is det.
74+
75+two_atoms(list(_), list(_), maybe.error("Args 1 and 2 not atoms")).
76+two_atoms(atom(_), list(_), maybe.error("Arg 2 not atom")).
77+two_atoms(list(_), atom(_), maybe.error("Arg 1 not atom")).
78+two_atoms(atom(A), atom(B), maybe.ok({A, B})).
79+
80+:- pragma inline(two_atoms/3).
81+
82+%-----------------------------------------------------------------------------%
83+
84+:- pred two_atoms(list.list(element), maybe.maybe_error({string, string})).
85+:- mode two_atoms(in, out(maybe_unique_error)) is det.
86+
87+:- pragma inline(two_atoms/2).
88+
89+two_atoms(Args, Result) :-
90+ (
91+ Args = [],
92+ Result = maybe.error("no values")
93+ ;
94+ Args = [_|[]],
95+ Result = maybe.error("not 2 values (1)")
96+ ;
97+ Args = [_|[_|[_|_]]],
98+ Result = maybe.error(string.append(string.append(
99+ "not 2 values (", string.from_int(list.length(Args))),
100+ ")"))
101+ ;
102+ Args = [A|[B|[]]],
103+ two_atoms(A, B, Result)
104+ ).
105+
106+%-----------------------------------------------------------------------------%
107+
108+:- func arithmetic(func(int, int) = int, func(float, float) = float,
109+ number, number) = (string).
110+:- mode arithmetic(func(in, in) = (out) is det, func(in, in) = (uo) is det,
111+ in, in) = (uo) is det.
112+
113+arithmetic(Func, _, int(A), int(B)) = string.from_int(Func(A, B)).
114+arithmetic(_, Func, float(A), float(B)) = string.from_float(Func(A, B)).
115+arithmetic(_, Func, int(A), float(B)) = string.from_float(Func(float(A), B)).
116+arithmetic(_, Func, float(A), int(B)) = string.from_float(Func(A, float(B))).
117+
118+%-----------------------------------------------------------------------------%
119+
120+builtin_plus(ANum, BNum, arithmetic(int.plus, float_plus, ANum, BNum)).
121+builtin_minus(ANum, BNum, arithmetic(int.minus, float_minus, ANum, BNum)).
122+builtin_times(ANum, BNum, arithmetic(int.times, float_times, ANum, BNum)).
123+builtin_divide(ANum, BNum, arithmetic('int__div', float_divide, ANum, BNum)).
124+
125+%-----------------------------------------------------------------------------%
126+% Implementation of arithmetic operators.
127+:- pred arithmetic(math_pred,
128+ arithmetic, list.list(element), result).
129+:- mode arithmetic(math_pred,
130+ in, in, res_uo) is det.
131+
132+:- pragma inline(arithmetic/4).
133+
134+arithmetic(Pred, Op, Args, Result) :-
135+ two_atoms(Args, ArgsResult),
136+ (
137+ ArgsResult = maybe.error(Error),
138+ builtin_op_tag(arithmetic(Op), Tag),
139+ Result = maybe.error(func_error(Tag, 2, Error))
140+ ;
141+ ArgsResult = maybe.ok({AStr, BStr}),
142+ ( if
143+ number_type(AStr, ANum)
144+ then
145+ ( if
146+ number_type(BStr, BNum)
147+ then
148+ Pred(ANum, BNum, Out),
149+ Result = maybe.ok(atom(Out))
150+ else
151+ builtin_op_tag(arithmetic(Op), Tag),
152+ Result = maybe.error(func_error(
153+ Tag,
154+ 2,
155+ string.append(string.append(
156+ "arg 2 not a number (", BStr), ")")))
157+ )
158+ else
159+ builtin_op_tag(arithmetic(Op), Tag),
160+ Result = maybe.error(func_error(
161+ Tag,
162+ 2,
163+ string.append(string.append(
164+ "arg 1 not a number (", AStr), ")")))
165+ )
166+ ).
167+
168+%-----------------------------------------------------------------------------%
169+
170+builtin_arithmetic_bind(Pred, Op, Args, Out) :- arithmetic(Pred, Op, Args, Out).
--- a/turbolisp.runtime.builtin.comparison.m
+++ b/turbolisp.runtime.builtin.comparison.m
@@ -1,83 +1,83 @@
1-% Copyright (c) 2019 AlaskanEmily, Transnat Games
2-%
3-% This Source Code Form is subject to the terms of the Mozilla Public
4-% License, v. 2.0. If a copy of the MPL was not distributed with this
5-% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6-
7-:- module turbolisp.runtime.builtin.comparison.
8-
9-%=============================================================================%
10-% TurboLisp implementation details for comparison builtins.
11-:- interface.
12-%=============================================================================%
13-
14-:- func inverse(cmp_result) = cmp_result.
15-:- mode inverse(di) = (uo) is det.
16-:- mode inverse(in) = (out) is det.
17-
18-%-----------------------------------------------------------------------------%
19-
20-:- pred builtin_comparison_bind(cmp_pred, list(element), result, runtime, runtime).
21-:- mode builtin_comparison_bind(cmp_pred, in, res_uo, in, out) is det.
22-
23-%-----------------------------------------------------------------------------%
24-
25-:- pred atom_compare(string::in, string::in, comparison_result::uo) is det.
26-
27-%=============================================================================%
28-:- implementation.
29-%=============================================================================%
30-
31-:- use_module exception.
32-
33-%-----------------------------------------------------------------------------%
34-
35-:- pragma inline(builtin_comparison_bind/5).
36-:- pragma inline(inverse/1).
37-
38-%-----------------------------------------------------------------------------%
39-
40-inverse(error(Error)) = error(Error).
41-inverse(yes) = no.
42-inverse(no) = yes.
43-
44-%-----------------------------------------------------------------------------%
45-
46-builtin_comparison_bind(Pred, Args, Result, !Runtime) :-
47- ( if
48- Args = [A, B, Y, N]
49- then
50- Pred(A, B, CmpResult),
51- (
52- CmpResult = yes,
53- Result = maybe.ok(Y)
54- ;
55- CmpResult = no,
56- Result = maybe.ok(N)
57- ;
58- CmpResult = error(Error),
59- Result = maybe.error(Error)
60- )
61- else
62- exception.throw(exception.software_error(
63- "Wrong arity in comparison func (builtin_bind is probably broken)"))
64- ).
65-
66-%-----------------------------------------------------------------------------%
67-
68-atom_compare(A, B, Cmp) :-
69- ( if
70- number_type(A, ANum),
71- number_type(B, BNum)
72- then
73- ( if
74- as_int(ANum, BNum, AInt, BInt)
75- then
76- builtin.compare(Cmp, AInt, BInt)
77- else
78- promote(ANum, BNum, AFloat, BFloat),
79- builtin.compare(Cmp, AFloat, BFloat)
80- )
81- else
82- builtin.compare(Cmp, A, B)
83- ).
1+% Copyright (c) 2019 AlaskanEmily, Transnat Games
2+%
3+% This Source Code Form is subject to the terms of the Mozilla Public
4+% License, v. 2.0. If a copy of the MPL was not distributed with this
5+% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6+
7+:- module turbolisp.runtime.builtin.comparison.
8+
9+%=============================================================================%
10+% TurboLisp implementation details for comparison builtins.
11+:- interface.
12+%=============================================================================%
13+
14+:- func inverse(cmp_result) = cmp_result.
15+:- mode inverse(di) = (uo) is det.
16+:- mode inverse(in) = (out) is det.
17+
18+%-----------------------------------------------------------------------------%
19+
20+:- pred builtin_comparison_bind(cmp_pred, list(element), result, runtime, runtime).
21+:- mode builtin_comparison_bind(cmp_pred, in, res_uo, in, out) is det.
22+
23+%-----------------------------------------------------------------------------%
24+
25+:- pred atom_compare(string::in, string::in, comparison_result::uo) is det.
26+
27+%=============================================================================%
28+:- implementation.
29+%=============================================================================%
30+
31+:- use_module exception.
32+
33+%-----------------------------------------------------------------------------%
34+
35+:- pragma inline(builtin_comparison_bind/5).
36+:- pragma inline(inverse/1).
37+
38+%-----------------------------------------------------------------------------%
39+
40+inverse(error(Error)) = error(Error).
41+inverse(yes) = no.
42+inverse(no) = yes.
43+
44+%-----------------------------------------------------------------------------%
45+
46+builtin_comparison_bind(Pred, Args, Result, !Runtime) :-
47+ ( if
48+ Args = [A, B, Y, N]
49+ then
50+ Pred(A, B, CmpResult),
51+ (
52+ CmpResult = yes,
53+ Result = maybe.ok(Y)
54+ ;
55+ CmpResult = no,
56+ Result = maybe.ok(N)
57+ ;
58+ CmpResult = error(Error),
59+ Result = maybe.error(Error)
60+ )
61+ else
62+ exception.throw(exception.software_error(
63+ "Wrong arity in comparison func (builtin_bind is probably broken)"))
64+ ).
65+
66+%-----------------------------------------------------------------------------%
67+
68+atom_compare(A, B, Cmp) :-
69+ ( if
70+ number_type(A, ANum),
71+ number_type(B, BNum)
72+ then
73+ ( if
74+ as_int(ANum, BNum, AInt, BInt)
75+ then
76+ builtin.compare(Cmp, AInt, BInt)
77+ else
78+ promote(ANum, BNum, AFloat, BFloat),
79+ builtin.compare(Cmp, AFloat, BFloat)
80+ )
81+ else
82+ builtin.compare(Cmp, A, B)
83+ ).
--- a/turbolisp.runtime.builtin.m
+++ b/turbolisp.runtime.builtin.m
@@ -1,443 +1,443 @@
1-% Copyright (c) 2019 AlaskanEmily, Transnat Games
2-%
3-% This Source Code Form is subject to the terms of the Mozilla Public
4-% License, v. 2.0. If a copy of the MPL was not distributed with this
5-% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6-
7-:- module turbolisp.runtime.builtin.
8-
9-%=============================================================================%
10-% TurboLisp builtins
11-:- interface.
12-%=============================================================================%
13-
14-:- use_module enum.
15-
16-%-----------------------------------------------------------------------------%
17-
18-:- type arithmetic --->
19- plus ;
20- minus ;
21- times ;
22- divide.
23-
24-%-----------------------------------------------------------------------------%
25-
26-:- instance enum.enum(arithmetic).
27-
28-%-----------------------------------------------------------------------------%
29-
30-:- type logic --->
31- int_and ;
32- int_or ;
33- int_xor.
34-
35-%-----------------------------------------------------------------------------%
36-
37-:- instance enum.enum(logic).
38-
39-%-----------------------------------------------------------------------------%
40-
41-:- type comparison --->
42- eq ;
43- ne ;
44- lt ;
45- gt ;
46- le ;
47- ge.
48-
49-%-----------------------------------------------------------------------------%
50-
51-:- instance enum.enum(comparison).
52-
53-%-----------------------------------------------------------------------------%
54-
55-:- pred comparison_tag(comparison, string).
56-:- mode comparison_tag(in, out) is det.
57-:- mode comparison_tag(out, in) is semidet.
58-:- mode comparison_tag(out, ui) is semidet. % Iffy
59-:- mode comparison_tag(in, in) is semidet. % Implied
60-
61-%-----------------------------------------------------------------------------%
62-
63-:- type define --->
64- def ;
65- let ;
66- fn.
67-
68-%-----------------------------------------------------------------------------%
69-
70-:- instance enum.enum(define).
71-
72-%-----------------------------------------------------------------------------%
73-
74-:- type builtin_op --->
75- arithmetic(arithmetic) ;
76- logic(logic) ;
77- comparison(comparison) ;
78- define(define).
79-
80-%-----------------------------------------------------------------------------%
81-
82-:- instance enum.enum(builtin_op).
83-
84-%-----------------------------------------------------------------------------%
85-
86-:- pred builtin_op_enum(builtin_op, int).
87-:- mode builtin_op_enum(in, out) is det.
88-:- mode builtin_op_enum(out, in) is semidet.
89-:- mode builtin_op_enum(in, in) is semidet. % Implied
90-
91-%-----------------------------------------------------------------------------%
92-
93-:- pred builtin_op_tag(builtin_op, string).
94-:- mode builtin_op_tag(in, out) is det.
95-:- mode builtin_op_tag(out, in) is semidet.
96-:- mode builtin_op_tag(out, ui) is semidet. % Iffy
97-:- mode builtin_op_tag(in, in) is semidet. % Implied
98-
99-%-----------------------------------------------------------------------------%
100-% Numeric components shared between comparison, arithmetic, and logic.
101-%-----------------------------------------------------------------------------%
102-
103-% Used to determine if a number is a float or an int.
104-:- type number ---> float(float) ; int(int).
105-
106-%-----------------------------------------------------------------------------%
107-% Promotes both numbers to floats.
108-:- pred promote(number::in, number::in, float::out, float::out) is det.
109-
110-%-----------------------------------------------------------------------------%
111-% Unifies iff both numbers are the integer functor for the ints
112-:- pred as_int(number, number, int, int).
113-:- mode as_int(in, in, out, out) is semidet.
114-:- mode as_int(di, di, uo, uo) is semidet.
115-:- mode as_int(out, out, in, in) is det.
116-:- mode as_int(uo, uo, di, di) is det.
117-:- mode as_int(in, in, in, in) is semidet. % Implied.
118-
119-%-----------------------------------------------------------------------------%
120-% number_type(NumStr, Num)
121-:- pred number_type(string::in, number::uo) is semidet.
122-
123-%-----------------------------------------------------------------------------%
124-% Comparison components.
125-%-----------------------------------------------------------------------------%
126-
127-% Result of the builtin comparisons.
128-:- type cmp_result ---> yes ; no ; error(string).
129-
130-%-----------------------------------------------------------------------------%
131-% Runs the builtin comparison predicate.
132-:- pred comparison(comparison, element, element, cmp_result).
133-:- mode comparison(in, in, in, uo) is det.
134-
135-%-----------------------------------------------------------------------------%
136-
137-:- type cmp_pred == (pred(element, element, cmp_result)).
138-:- mode cmp_pred == (pred(in, in, uo) is det).
139-:- inst cmp_pred == (pred(in, in, uo) is det).
140-
141-%-----------------------------------------------------------------------------%
142-% Comparison builtins. These are aggressively inlined by the compilation
143-% phase, so they must be exported to the runtime.
144-:- pred builtin_eq `with_type` cmp_pred `with_inst` cmp_pred.
145-:- pred builtin_ne `with_type` cmp_pred `with_inst` cmp_pred.
146-:- pred builtin_lt `with_type` cmp_pred `with_inst` cmp_pred.
147-:- pred builtin_gt `with_type` cmp_pred `with_inst` cmp_pred.
148-:- pred builtin_le `with_type` cmp_pred `with_inst` cmp_pred.
149-:- pred builtin_ge `with_type` cmp_pred `with_inst` cmp_pred.
150-
151-%-----------------------------------------------------------------------------%
152-
153-:- pred builtin_eq_bind `with_type` execute_pred `with_inst` execute_pred.
154-:- pred builtin_ne_bind `with_type` execute_pred `with_inst` execute_pred.
155-:- pred builtin_lt_bind `with_type` execute_pred `with_inst` execute_pred.
156-:- pred builtin_gt_bind `with_type` execute_pred `with_inst` execute_pred.
157-:- pred builtin_le_bind `with_type` execute_pred `with_inst` execute_pred.
158-:- pred builtin_ge_bind `with_type` execute_pred `with_inst` execute_pred.
159-
160-%-----------------------------------------------------------------------------%
161-% Arithmetic components.
162-%-----------------------------------------------------------------------------%
163-
164-:- pred builtin_plus_bind `with_type` execute_pred `with_inst` execute_pred.
165-:- pred builtin_minus_bind `with_type` execute_pred `with_inst` execute_pred.
166-:- pred builtin_times_bind `with_type` execute_pred `with_inst` execute_pred.
167-:- pred builtin_divide_bind `with_type` execute_pred `with_inst` execute_pred.
168-
169-%-----------------------------------------------------------------------------%
170-% Define components.
171-%-----------------------------------------------------------------------------%
172-
173-%:- pred builtin_let_bind `with_type` execute_pred `with_inst` execute_pred.
174-%:- pred builtin_def_bind `with_type` execute_pred `with_inst` execute_pred.
175-:- pred builtin_fn_bind `with_type` execute_pred `with_inst` execute_pred.
176-
177-%=============================================================================%
178-:- implementation.
179-%=============================================================================%
180-
181-:- use_module char.
182-:- use_module exception.
183-
184-:- include_module turbolisp.runtime.builtin.comparison.
185-:- import_module turbolisp.runtime.builtin.comparison.
186-
187-:- include_module turbolisp.runtime.builtin.arithmetic.
188-:- import_module turbolisp.runtime.builtin.arithmetic.
189-
190-%-----------------------------------------------------------------------------%
191-
192-:- pragma inline(comparison/4).
193-:- pragma inline(builtin_op_tag/2).
194-:- pragma inline(builtin_op_enum/2).
195-
196-%-----------------------------------------------------------------------------%
197-
198-:- pragma inline(comparison/4).
199-:- pragma inline(builtin_eq/3).
200-:- pragma inline(builtin_lt/3).
201-:- pragma inline(builtin_gt/3).
202-:- pragma inline(builtin_le/3).
203-:- pragma inline(builtin_ge/3).
204-
205-%-----------------------------------------------------------------------------%
206-
207-:- instance enum.enum(arithmetic) where [
208- ( to_int(E) = I :- builtin_op_enum(arithmetic(E), I) ),
209- ( from_int(I) = E :- builtin_op_enum(arithmetic(E), I) )
210-].
211-
212-%-----------------------------------------------------------------------------%
213-
214-:- instance enum.enum(logic) where [
215- ( to_int(E) = I :- builtin_op_enum(logic(E), I) ),
216- ( from_int(I) = E :- builtin_op_enum(logic(E), I) )
217-].
218-
219-%-----------------------------------------------------------------------------%
220-
221-:- instance enum.enum(comparison) where [
222- ( to_int(E) = I :- builtin_op_enum(comparison(E), I) ),
223- ( from_int(I) = E :- builtin_op_enum(comparison(E), I) )
224-].
225-
226-%-----------------------------------------------------------------------------%
227-
228-comparison_tag(Cmp, Tag) :-
229- builtin_op_tag(comparison(Cmp), Tag).
230-
231-%-----------------------------------------------------------------------------%
232-
233-:- instance enum.enum(define) where [
234- ( to_int(E) = I :- builtin_op_enum(define(E), I) ),
235- ( from_int(I) = E :- builtin_op_enum(define(E), I) )
236-].
237-
238-%-----------------------------------------------------------------------------%
239-
240-:- instance enum.enum(builtin_op) where [
241- ( to_int(E) = I :- builtin_op_enum(E, I) ),
242- ( from_int(I) = E :- builtin_op_enum(E, I) )
243-].
244-
245-%-----------------------------------------------------------------------------%
246-
247-builtin_op_enum(arithmetic(plus), 0).
248-builtin_op_enum(arithmetic(minus), 1).
249-builtin_op_enum(arithmetic(times), 2).
250-builtin_op_enum(arithmetic(divide), 3).
251-builtin_op_enum(logic(int_and), 4).
252-builtin_op_enum(logic(int_or), 5).
253-builtin_op_enum(logic(int_xor), 6).
254-builtin_op_enum(comparison(eq), 7).
255-builtin_op_enum(comparison(ne), 8).
256-builtin_op_enum(comparison(lt), 9).
257-builtin_op_enum(comparison(gt), 10).
258-builtin_op_enum(comparison(le), 11).
259-builtin_op_enum(comparison(ge), 12).
260-builtin_op_enum(define(def), 13).
261-builtin_op_enum(define(let), 14).
262-builtin_op_enum(define(fn), 15).
263-
264-%-----------------------------------------------------------------------------%
265-
266-builtin_op_tag(arithmetic(plus), "+").
267-builtin_op_tag(arithmetic(minus), "-").
268-builtin_op_tag(arithmetic(times), "*").
269-builtin_op_tag(arithmetic(divide), "/").
270-builtin_op_tag(logic(int_and), "&").
271-builtin_op_tag(logic(int_or), "|").
272-builtin_op_tag(logic(int_xor), "^").
273-builtin_op_tag(comparison(eq), "=").
274-builtin_op_tag(comparison(ne), "!").
275-builtin_op_tag(comparison(lt), "<").
276-builtin_op_tag(comparison(gt), ">").
277-builtin_op_tag(comparison(le), "<=").
278-builtin_op_tag(comparison(ge), ">=").
279-builtin_op_tag(define(def), "def").
280-builtin_op_tag(define(let), "let").
281-builtin_op_tag(define(fn), "fn").
282-
283-%-----------------------------------------------------------------------------%
284-
285-comparison(eq, E1, E2, Result) :- builtin_eq(E1, E2, Result).
286-comparison(ne, E1, E2, Result) :- builtin_ne(E1, E2, Result).
287-comparison(lt, E1, E2, Result) :- builtin_lt(E1, E2, Result).
288-comparison(gt, E1, E2, Result) :- builtin_gt(E1, E2, Result).
289-comparison(le, E1, E2, Result) :- builtin_le(E1, E2, Result).
290-comparison(ge, E1, E2, Result) :- builtin_ge(E1, E2, Result).
291-
292-%-----------------------------------------------------------------------------%
293-
294-promote(float(A), float(B), A, B).
295-promote(int(A), float(B), int_to_float(A), B).
296-promote(float(A), int(B), A, int_to_float(B)).
297-promote(int(A), int(B), int_to_float(A), int_to_float(B)).
298-
299-%-----------------------------------------------------------------------------%
300-
301-as_int(int(A), int(B), A, B).
302-
303-%-----------------------------------------------------------------------------%
304-
305-:- pred digit_or_dot(character::in) is semidet.
306-digit_or_dot(C) :-
307- ( not C = ('.') ) => char.is_digit(C).
308-
309-%-----------------------------------------------------------------------------%
310-
311-number_type(In, Out) :-
312- ( if
313- string.all_match(char.is_digit, In)
314- then
315- string.to_int(In, Int),
316- builtin__copy(Int, UniqInt),
317- Out = int(UniqInt)
318- else if
319- string.all_match(digit_or_dot, In)
320- then
321- string.to_float(In, Float),
322- builtin__copy(Float, UniqFloat),
323- Out = float(UniqFloat)
324- else
325- string.remove_prefix("0x", In, InP),
326- string.all_match(char.is_hex_digit, InP),
327- string.base_string_to_int(16, InP, Int),
328- builtin__copy(Int, UniqInt),
329- Out = int(UniqInt)
330- ).
331-
332-%-----------------------------------------------------------------------------%
333-
334-builtin_eq(A, B, Result) :- ( A = B -> Result = yes ; Result = no ).
335-
336-builtin_ne(A, B, Result) :- ( A = B -> Result = no ; Result = yes ).
337-
338-builtin_lt(list(_), list(_), error("Error: `lt/2` -> test two lists")).
339-builtin_lt(atom(_), list(_), error("Error: `lt/2` -> test atom and list")).
340-builtin_lt(list(_), atom(_), error("Error: `lt/2` -> test list and atom")).
341-builtin_lt(atom(A), atom(B), Result) :-
342- ( atom_compare(A, B, (<)) -> Result = yes ; Result = no ).
343-
344-builtin_gt(list(_), list(_), error("Error: `gt/2` -> test two lists")).
345-builtin_gt(atom(_), list(_), error("Error: `gt/2` -> test atom and list")).
346-builtin_gt(list(_), atom(_), error("Error: `gt/2` -> test list and atom")).
347-builtin_gt(atom(A), atom(B), Result) :-
348- ( atom_compare(A, B, (>)) -> Result = yes ; Result = no ).
349-
350-builtin_le(list(_), list(_), error("Error: `le/2` -> test two lists")).
351-builtin_le(atom(_), list(_), error("Error: `le/2` -> test atom and list")).
352-builtin_le(list(_), atom(_), error("Error: `le/2` -> test list and atom")).
353-builtin_le(atom(A), atom(B), Result) :-
354- ( atom_compare(A, B, (>)) -> Result = no ; Result = yes ).
355-
356-builtin_ge(list(_), list(_), error("Error: `ge/2` -> test two lists")).
357-builtin_ge(atom(_), list(_), error("Error: `ge/2` -> test atom and list")).
358-builtin_ge(list(_), atom(_), error("Error: `ge/2` -> test list and atom")).
359-builtin_ge(atom(A), atom(B), Result) :-
360- ( atom_compare(A, B, (<)) -> Result = no ; Result = yes ).
361-
362-%-----------------------------------------------------------------------------%
363-
364-builtin_eq_bind(E, R, !RT) :- builtin_comparison_bind(builtin_eq, E, R, !RT).
365-builtin_ne_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ne, E, R, !RT).
366-builtin_lt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_lt, E, R, !RT).
367-builtin_gt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_gt, E, R, !RT).
368-builtin_le_bind(E, R, !RT) :- builtin_comparison_bind(builtin_le, E, R, !RT).
369-builtin_ge_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ge, E, R, !RT).
370-
371-%-----------------------------------------------------------------------------%
372-
373-builtin_plus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_plus, plus, E, R).
374-builtin_minus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_minus, minus, E, R).
375-builtin_times_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_times, times, E, R).
376-builtin_divide_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_divide, divide, E, R).
377-
378-%-----------------------------------------------------------------------------%
379-% Used to implement let and def
380-
381-%-----------------------------------------------------------------------------%
382-% Used to parse argument names in fn/3
383-:- pred fn_arg(element, string, int, int, maybe.maybe_error, maybe.maybe_error).
384-:- mode fn_arg(in, out, in, out, di, uo) is det.
385-%:- mode fn_arg(di, uo, in, out, di, uo) is det.
386-
387-fn_arg(_, "", I, inc(I), maybe.error(E), maybe.error(E)).
388-fn_arg(list(_), "", I, inc(I), maybe.ok,
389- maybe.error(string.append(string.append(
390- "Error: `fn/3` -> Arg list element ",
391- string.from_int(I)),
392- " is a list"))).
393-fn_arg(atom(Str), Str, I, inc(I), maybe.ok, maybe.ok).
394-
395-%-----------------------------------------------------------------------------%
396-% Used to implement fn
397-:- type fn_parse_result == {string, list(string), list(element), int}.
398-:- pred fn_parse(list.list(element), maybe.maybe_error(fn_parse_result)).
399-:- mode fn_parse(in, res_uo) is det.
400-
401-fn_parse(Element, Result) :-
402- ( if
403- Element = [NameElement|[ArgsElement|Body]]
404- then
405- (
406- NameElement = list(_),
407- Result = maybe.error("Error: `fn/3` -> arg 1 is a list")
408- ;
409- NameElement = atom(Name),
410- (
411- ArgsElement = atom(_),
412- Result = maybe.error("Error: `fn/3` -> arg 2 is an atom")
413- ;
414- ArgsElement = list(Args),
415- % Validate the arguments, and construct a list of names.
416- list.map_foldl2(fn_arg,
417- Args, ArgNames, 0, Arity, maybe.ok, ArgsResult),
418- (
419- ArgsResult = maybe.ok,
420- Result = maybe.ok({Name, ArgNames, Body, Arity})
421- ;
422- ArgsResult = maybe.error(Error),
423- Result = maybe.error(Error)
424- )
425- )
426- )
427- else
428- exception.throw(exception.software_error(
429- "Wrong arity in `fn/3` (builtin_bind is probably broken)"))
430- ).
431-
432-%-----------------------------------------------------------------------------%
433-
434-builtin_fn_bind(Element, Result, !Runtime) :-
435- fn_parse(Element, FnResult),
436- (
437- FnResult = maybe.error(Error),
438- Result = maybe.error(Error)
439- ;
440- FnResult = maybe.ok({Name, ArgNames, Body, Arity}),
441- def_bind(args(Name, Arity), lisp_bind(ArgNames, Body), !Runtime),
442- Result = maybe.ok(atom(Name))
443- ).
1+% Copyright (c) 2019 AlaskanEmily, Transnat Games
2+%
3+% This Source Code Form is subject to the terms of the Mozilla Public
4+% License, v. 2.0. If a copy of the MPL was not distributed with this
5+% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6+
7+:- module turbolisp.runtime.builtin.
8+
9+%=============================================================================%
10+% TurboLisp builtins
11+:- interface.
12+%=============================================================================%
13+
14+:- use_module enum.
15+
16+%-----------------------------------------------------------------------------%
17+
18+:- type arithmetic --->
19+ plus ;
20+ minus ;
21+ times ;
22+ divide.
23+
24+%-----------------------------------------------------------------------------%
25+
26+:- instance enum.enum(arithmetic).
27+
28+%-----------------------------------------------------------------------------%
29+
30+:- type logic --->
31+ int_and ;
32+ int_or ;
33+ int_xor.
34+
35+%-----------------------------------------------------------------------------%
36+
37+:- instance enum.enum(logic).
38+
39+%-----------------------------------------------------------------------------%
40+
41+:- type comparison --->
42+ eq ;
43+ ne ;
44+ lt ;
45+ gt ;
46+ le ;
47+ ge.
48+
49+%-----------------------------------------------------------------------------%
50+
51+:- instance enum.enum(comparison).
52+
53+%-----------------------------------------------------------------------------%
54+
55+:- pred comparison_tag(comparison, string).
56+:- mode comparison_tag(in, out) is det.
57+:- mode comparison_tag(out, in) is semidet.
58+:- mode comparison_tag(out, ui) is semidet. % Iffy
59+:- mode comparison_tag(in, in) is semidet. % Implied
60+
61+%-----------------------------------------------------------------------------%
62+
63+:- type define --->
64+ def ;
65+ let ;
66+ fn.
67+
68+%-----------------------------------------------------------------------------%
69+
70+:- instance enum.enum(define).
71+
72+%-----------------------------------------------------------------------------%
73+
74+:- type builtin_op --->
75+ arithmetic(arithmetic) ;
76+ logic(logic) ;
77+ comparison(comparison) ;
78+ define(define).
79+
80+%-----------------------------------------------------------------------------%
81+
82+:- instance enum.enum(builtin_op).
83+
84+%-----------------------------------------------------------------------------%
85+
86+:- pred builtin_op_enum(builtin_op, int).
87+:- mode builtin_op_enum(in, out) is det.
88+:- mode builtin_op_enum(out, in) is semidet.
89+:- mode builtin_op_enum(in, in) is semidet. % Implied
90+
91+%-----------------------------------------------------------------------------%
92+
93+:- pred builtin_op_tag(builtin_op, string).
94+:- mode builtin_op_tag(in, out) is det.
95+:- mode builtin_op_tag(out, in) is semidet.
96+:- mode builtin_op_tag(out, ui) is semidet. % Iffy
97+:- mode builtin_op_tag(in, in) is semidet. % Implied
98+
99+%-----------------------------------------------------------------------------%
100+% Numeric components shared between comparison, arithmetic, and logic.
101+%-----------------------------------------------------------------------------%
102+
103+% Used to determine if a number is a float or an int.
104+:- type number ---> float(float) ; int(int).
105+
106+%-----------------------------------------------------------------------------%
107+% Promotes both numbers to floats.
108+:- pred promote(number::in, number::in, float::out, float::out) is det.
109+
110+%-----------------------------------------------------------------------------%
111+% Unifies iff both numbers are the integer functor for the ints
112+:- pred as_int(number, number, int, int).
113+:- mode as_int(in, in, out, out) is semidet.
114+:- mode as_int(di, di, uo, uo) is semidet.
115+:- mode as_int(out, out, in, in) is det.
116+:- mode as_int(uo, uo, di, di) is det.
117+:- mode as_int(in, in, in, in) is semidet. % Implied.
118+
119+%-----------------------------------------------------------------------------%
120+% number_type(NumStr, Num)
121+:- pred number_type(string::in, number::uo) is semidet.
122+
123+%-----------------------------------------------------------------------------%
124+% Comparison components.
125+%-----------------------------------------------------------------------------%
126+
127+% Result of the builtin comparisons.
128+:- type cmp_result ---> yes ; no ; error(string).
129+
130+%-----------------------------------------------------------------------------%
131+% Runs the builtin comparison predicate.
132+:- pred comparison(comparison, element, element, cmp_result).
133+:- mode comparison(in, in, in, uo) is det.
134+
135+%-----------------------------------------------------------------------------%
136+
137+:- type cmp_pred == (pred(element, element, cmp_result)).
138+:- mode cmp_pred == (pred(in, in, uo) is det).
139+:- inst cmp_pred == (pred(in, in, uo) is det).
140+
141+%-----------------------------------------------------------------------------%
142+% Comparison builtins. These are aggressively inlined by the compilation
143+% phase, so they must be exported to the runtime.
144+:- pred builtin_eq `with_type` cmp_pred `with_inst` cmp_pred.
145+:- pred builtin_ne `with_type` cmp_pred `with_inst` cmp_pred.
146+:- pred builtin_lt `with_type` cmp_pred `with_inst` cmp_pred.
147+:- pred builtin_gt `with_type` cmp_pred `with_inst` cmp_pred.
148+:- pred builtin_le `with_type` cmp_pred `with_inst` cmp_pred.
149+:- pred builtin_ge `with_type` cmp_pred `with_inst` cmp_pred.
150+
151+%-----------------------------------------------------------------------------%
152+
153+:- pred builtin_eq_bind `with_type` execute_pred `with_inst` execute_pred.
154+:- pred builtin_ne_bind `with_type` execute_pred `with_inst` execute_pred.
155+:- pred builtin_lt_bind `with_type` execute_pred `with_inst` execute_pred.
156+:- pred builtin_gt_bind `with_type` execute_pred `with_inst` execute_pred.
157+:- pred builtin_le_bind `with_type` execute_pred `with_inst` execute_pred.
158+:- pred builtin_ge_bind `with_type` execute_pred `with_inst` execute_pred.
159+
160+%-----------------------------------------------------------------------------%
161+% Arithmetic components.
162+%-----------------------------------------------------------------------------%
163+
164+:- pred builtin_plus_bind `with_type` execute_pred `with_inst` execute_pred.
165+:- pred builtin_minus_bind `with_type` execute_pred `with_inst` execute_pred.
166+:- pred builtin_times_bind `with_type` execute_pred `with_inst` execute_pred.
167+:- pred builtin_divide_bind `with_type` execute_pred `with_inst` execute_pred.
168+
169+%-----------------------------------------------------------------------------%
170+% Define components.
171+%-----------------------------------------------------------------------------%
172+
173+%:- pred builtin_let_bind `with_type` execute_pred `with_inst` execute_pred.
174+%:- pred builtin_def_bind `with_type` execute_pred `with_inst` execute_pred.
175+:- pred builtin_fn_bind `with_type` execute_pred `with_inst` execute_pred.
176+
177+%=============================================================================%
178+:- implementation.
179+%=============================================================================%
180+
181+:- use_module char.
182+:- use_module exception.
183+
184+:- include_module turbolisp.runtime.builtin.comparison.
185+:- import_module turbolisp.runtime.builtin.comparison.
186+
187+:- include_module turbolisp.runtime.builtin.arithmetic.
188+:- import_module turbolisp.runtime.builtin.arithmetic.
189+
190+%-----------------------------------------------------------------------------%
191+
192+:- pragma inline(comparison/4).
193+:- pragma inline(builtin_op_tag/2).
194+:- pragma inline(builtin_op_enum/2).
195+
196+%-----------------------------------------------------------------------------%
197+
198+:- pragma inline(comparison/4).
199+:- pragma inline(builtin_eq/3).
200+:- pragma inline(builtin_lt/3).
201+:- pragma inline(builtin_gt/3).
202+:- pragma inline(builtin_le/3).
203+:- pragma inline(builtin_ge/3).
204+
205+%-----------------------------------------------------------------------------%
206+
207+:- instance enum.enum(arithmetic) where [
208+ ( to_int(E) = I :- builtin_op_enum(arithmetic(E), I) ),
209+ ( from_int(I) = E :- builtin_op_enum(arithmetic(E), I) )
210+].
211+
212+%-----------------------------------------------------------------------------%
213+
214+:- instance enum.enum(logic) where [
215+ ( to_int(E) = I :- builtin_op_enum(logic(E), I) ),
216+ ( from_int(I) = E :- builtin_op_enum(logic(E), I) )
217+].
218+
219+%-----------------------------------------------------------------------------%
220+
221+:- instance enum.enum(comparison) where [
222+ ( to_int(E) = I :- builtin_op_enum(comparison(E), I) ),
223+ ( from_int(I) = E :- builtin_op_enum(comparison(E), I) )
224+].
225+
226+%-----------------------------------------------------------------------------%
227+
228+comparison_tag(Cmp, Tag) :-
229+ builtin_op_tag(comparison(Cmp), Tag).
230+
231+%-----------------------------------------------------------------------------%
232+
233+:- instance enum.enum(define) where [
234+ ( to_int(E) = I :- builtin_op_enum(define(E), I) ),
235+ ( from_int(I) = E :- builtin_op_enum(define(E), I) )
236+].
237+
238+%-----------------------------------------------------------------------------%
239+
240+:- instance enum.enum(builtin_op) where [
241+ ( to_int(E) = I :- builtin_op_enum(E, I) ),
242+ ( from_int(I) = E :- builtin_op_enum(E, I) )
243+].
244+
245+%-----------------------------------------------------------------------------%
246+
247+builtin_op_enum(arithmetic(plus), 0).
248+builtin_op_enum(arithmetic(minus), 1).
249+builtin_op_enum(arithmetic(times), 2).
250+builtin_op_enum(arithmetic(divide), 3).
251+builtin_op_enum(logic(int_and), 4).
252+builtin_op_enum(logic(int_or), 5).
253+builtin_op_enum(logic(int_xor), 6).
254+builtin_op_enum(comparison(eq), 7).
255+builtin_op_enum(comparison(ne), 8).
256+builtin_op_enum(comparison(lt), 9).
257+builtin_op_enum(comparison(gt), 10).
258+builtin_op_enum(comparison(le), 11).
259+builtin_op_enum(comparison(ge), 12).
260+builtin_op_enum(define(def), 13).
261+builtin_op_enum(define(let), 14).
262+builtin_op_enum(define(fn), 15).
263+
264+%-----------------------------------------------------------------------------%
265+
266+builtin_op_tag(arithmetic(plus), "+").
267+builtin_op_tag(arithmetic(minus), "-").
268+builtin_op_tag(arithmetic(times), "*").
269+builtin_op_tag(arithmetic(divide), "/").
270+builtin_op_tag(logic(int_and), "&").
271+builtin_op_tag(logic(int_or), "|").
272+builtin_op_tag(logic(int_xor), "^").
273+builtin_op_tag(comparison(eq), "=").
274+builtin_op_tag(comparison(ne), "!").
275+builtin_op_tag(comparison(lt), "<").
276+builtin_op_tag(comparison(gt), ">").
277+builtin_op_tag(comparison(le), "<=").
278+builtin_op_tag(comparison(ge), ">=").
279+builtin_op_tag(define(def), "def").
280+builtin_op_tag(define(let), "let").
281+builtin_op_tag(define(fn), "fn").
282+
283+%-----------------------------------------------------------------------------%
284+
285+comparison(eq, E1, E2, Result) :- builtin_eq(E1, E2, Result).
286+comparison(ne, E1, E2, Result) :- builtin_ne(E1, E2, Result).
287+comparison(lt, E1, E2, Result) :- builtin_lt(E1, E2, Result).
288+comparison(gt, E1, E2, Result) :- builtin_gt(E1, E2, Result).
289+comparison(le, E1, E2, Result) :- builtin_le(E1, E2, Result).
290+comparison(ge, E1, E2, Result) :- builtin_ge(E1, E2, Result).
291+
292+%-----------------------------------------------------------------------------%
293+
294+promote(float(A), float(B), A, B).
295+promote(int(A), float(B), int_to_float(A), B).
296+promote(float(A), int(B), A, int_to_float(B)).
297+promote(int(A), int(B), int_to_float(A), int_to_float(B)).
298+
299+%-----------------------------------------------------------------------------%
300+
301+as_int(int(A), int(B), A, B).
302+
303+%-----------------------------------------------------------------------------%
304+
305+:- pred digit_or_dot(character::in) is semidet.
306+digit_or_dot(C) :-
307+ ( not C = ('.') ) => char.is_digit(C).
308+
309+%-----------------------------------------------------------------------------%
310+
311+number_type(In, Out) :-
312+ ( if
313+ string.all_match(char.is_digit, In)
314+ then
315+ string.to_int(In, Int),
316+ builtin__copy(Int, UniqInt),
317+ Out = int(UniqInt)
318+ else if
319+ string.all_match(digit_or_dot, In)
320+ then
321+ string.to_float(In, Float),
322+ builtin__copy(Float, UniqFloat),
323+ Out = float(UniqFloat)
324+ else
325+ string.remove_prefix("0x", In, InP),
326+ string.all_match(char.is_hex_digit, InP),
327+ string.base_string_to_int(16, InP, Int),
328+ builtin__copy(Int, UniqInt),
329+ Out = int(UniqInt)
330+ ).
331+
332+%-----------------------------------------------------------------------------%
333+
334+builtin_eq(A, B, Result) :- ( A = B -> Result = yes ; Result = no ).
335+
336+builtin_ne(A, B, Result) :- ( A = B -> Result = no ; Result = yes ).
337+
338+builtin_lt(list(_), list(_), error("Error: `lt/2` -> test two lists")).
339+builtin_lt(atom(_), list(_), error("Error: `lt/2` -> test atom and list")).
340+builtin_lt(list(_), atom(_), error("Error: `lt/2` -> test list and atom")).
341+builtin_lt(atom(A), atom(B), Result) :-
342+ ( atom_compare(A, B, (<)) -> Result = yes ; Result = no ).
343+
344+builtin_gt(list(_), list(_), error("Error: `gt/2` -> test two lists")).
345+builtin_gt(atom(_), list(_), error("Error: `gt/2` -> test atom and list")).
346+builtin_gt(list(_), atom(_), error("Error: `gt/2` -> test list and atom")).
347+builtin_gt(atom(A), atom(B), Result) :-
348+ ( atom_compare(A, B, (>)) -> Result = yes ; Result = no ).
349+
350+builtin_le(list(_), list(_), error("Error: `le/2` -> test two lists")).
351+builtin_le(atom(_), list(_), error("Error: `le/2` -> test atom and list")).
352+builtin_le(list(_), atom(_), error("Error: `le/2` -> test list and atom")).
353+builtin_le(atom(A), atom(B), Result) :-
354+ ( atom_compare(A, B, (>)) -> Result = no ; Result = yes ).
355+
356+builtin_ge(list(_), list(_), error("Error: `ge/2` -> test two lists")).
357+builtin_ge(atom(_), list(_), error("Error: `ge/2` -> test atom and list")).
358+builtin_ge(list(_), atom(_), error("Error: `ge/2` -> test list and atom")).
359+builtin_ge(atom(A), atom(B), Result) :-
360+ ( atom_compare(A, B, (<)) -> Result = no ; Result = yes ).
361+
362+%-----------------------------------------------------------------------------%
363+
364+builtin_eq_bind(E, R, !RT) :- builtin_comparison_bind(builtin_eq, E, R, !RT).
365+builtin_ne_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ne, E, R, !RT).
366+builtin_lt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_lt, E, R, !RT).
367+builtin_gt_bind(E, R, !RT) :- builtin_comparison_bind(builtin_gt, E, R, !RT).
368+builtin_le_bind(E, R, !RT) :- builtin_comparison_bind(builtin_le, E, R, !RT).
369+builtin_ge_bind(E, R, !RT) :- builtin_comparison_bind(builtin_ge, E, R, !RT).
370+
371+%-----------------------------------------------------------------------------%
372+
373+builtin_plus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_plus, plus, E, R).
374+builtin_minus_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_minus, minus, E, R).
375+builtin_times_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_times, times, E, R).
376+builtin_divide_bind(E, R, !RT) :- builtin_arithmetic_bind(builtin_divide, divide, E, R).
377+
378+%-----------------------------------------------------------------------------%
379+% Used to implement let and def
380+
381+%-----------------------------------------------------------------------------%
382+% Used to parse argument names in fn/3
383+:- pred fn_arg(element, string, int, int, maybe.maybe_error, maybe.maybe_error).
384+:- mode fn_arg(in, out, in, out, di, uo) is det.
385+%:- mode fn_arg(di, uo, in, out, di, uo) is det.
386+
387+fn_arg(_, "", I, inc(I), maybe.error(E), maybe.error(E)).
388+fn_arg(list(_), "", I, inc(I), maybe.ok,
389+ maybe.error(string.append(string.append(
390+ "Error: `fn/3` -> Arg list element ",
391+ string.from_int(I)),
392+ " is a list"))).
393+fn_arg(atom(Str), Str, I, inc(I), maybe.ok, maybe.ok).
394+
395+%-----------------------------------------------------------------------------%
396+% Used to implement fn
397+:- type fn_parse_result == {string, list(string), list(element), int}.
398+:- pred fn_parse(list.list(element), maybe.maybe_error(fn_parse_result)).
399+:- mode fn_parse(in, res_uo) is det.
400+
401+fn_parse(Element, Result) :-
402+ ( if
403+ Element = [NameElement|[ArgsElement|Body]]
404+ then
405+ (
406+ NameElement = list(_),
407+ Result = maybe.error("Error: `fn/3` -> arg 1 is a list")
408+ ;
409+ NameElement = atom(Name),
410+ (
411+ ArgsElement = atom(_),
412+ Result = maybe.error("Error: `fn/3` -> arg 2 is an atom")
413+ ;
414+ ArgsElement = list(Args),
415+ % Validate the arguments, and construct a list of names.
416+ list.map_foldl2(fn_arg,
417+ Args, ArgNames, 0, Arity, maybe.ok, ArgsResult),
418+ (
419+ ArgsResult = maybe.ok,
420+ Result = maybe.ok({Name, ArgNames, Body, Arity})
421+ ;
422+ ArgsResult = maybe.error(Error),
423+ Result = maybe.error(Error)
424+ )
425+ )
426+ )
427+ else
428+ exception.throw(exception.software_error(
429+ "Wrong arity in `fn/3` (builtin_bind is probably broken)"))
430+ ).
431+
432+%-----------------------------------------------------------------------------%
433+
434+builtin_fn_bind(Element, Result, !Runtime) :-
435+ fn_parse(Element, FnResult),
436+ (
437+ FnResult = maybe.error(Error),
438+ Result = maybe.error(Error)
439+ ;
440+ FnResult = maybe.ok({Name, ArgNames, Body, Arity}),
441+ def_bind(args(Name, Arity), lisp_bind(ArgNames, Body), !Runtime),
442+ Result = maybe.ok(atom(Name))
443+ ).
--- a/turbolisp.runtime.m
+++ b/turbolisp.runtime.m
@@ -1,800 +1,800 @@
1-% Copyright (c) 2019 AlaskanEmily, Transnat Games
2-%
3-% This Source Code Form is subject to the terms of the Mozilla Public
4-% License, v. 2.0. If a copy of the MPL was not distributed with this
5-% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6-
7-:- module turbolisp.runtime.
8-
9-%=============================================================================%
10-% TurboLisp runtime components.
11-:- interface.
12-%=============================================================================%
13-
14-:- import_module list.
15-:- use_module assoc_list.
16-:- use_module rbtree.
17-:- use_module maybe.
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 turbolisp.runtime.builtin.
187-:- use_module turbolisp.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(turbolisp__runtime__builtin__builtin_eq_bind)).
392-builtin_bind(args("!", 4), mercury_bind(turbolisp__runtime__builtin__builtin_ne_bind)).
393-builtin_bind(args("<", 4), mercury_bind(turbolisp__runtime__builtin__builtin_lt_bind)).
394-builtin_bind(args(">", 4), mercury_bind(turbolisp__runtime__builtin__builtin_gt_bind)).
395-builtin_bind(args("<=", 4), mercury_bind(turbolisp__runtime__builtin__builtin_le_bind)).
396-builtin_bind(args(">=", 4), mercury_bind(turbolisp__runtime__builtin__builtin_ge_bind)).
397-
398-builtin_bind(args("+", 2), mercury_bind(turbolisp__runtime__builtin__builtin_plus_bind)).
399-builtin_bind(args("-", 2), mercury_bind(turbolisp__runtime__builtin__builtin_minus_bind)).
400-builtin_bind(args("*", 2), mercury_bind(turbolisp__runtime__builtin__builtin_times_bind)).
401-builtin_bind(args("/", 2), mercury_bind(turbolisp__runtime__builtin__builtin_divide_bind)).
402-
403-builtin_bind(args("fn", 3), mercury_bind(turbolisp__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(turbolisp.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- turbolisp.runtime.builtin.builtin_op_tag(Op, Tag),
518- turbolisp.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- turbolisp.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- turbolisp.runtime.builtin.comparison(Cmp, A, B, CmpResult),
594- (
595- CmpResult = turbolisp.runtime.builtin.error(_),
596- Result = FallbackResult
597- ;
598- (
599- CmpResult = turbolisp.runtime.builtin.yes, Choice = Y
600- ;
601- CmpResult = turbolisp.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- turbolisp__runtime__builtin__builtin_op_tag(
632- turbolisp__runtime__builtin__define(Op), Tag)
633- then
634- (
635- Op = turbolisp.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- turbolisp.runtime.builtin.builtin_fn_bind(Tail, _, !Runtime)
651- else
652- true
653- )
654- ;
655- Op = turbolisp.runtime.builtin.let
656- ;
657- Op = turbolisp.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- turbolisp.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- turbolisp.runtime.builtin.comparison(Cmp, A, B, CmpResult),
738- (
739- CmpResult = turbolisp.runtime.builtin.error(Error),
740- turbolisp.runtime.builtin.comparison_tag(Cmp, Tag),
741- Result = maybe.error(func_error(Tag, 2, Error))
742- ;
743- (
744- CmpResult = turbolisp.runtime.builtin.yes, Choice = Y
745- ;
746- CmpResult = turbolisp.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- turbolisp.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).
1+% Copyright (c) 2019 AlaskanEmily, Transnat Games
2+%
3+% This Source Code Form is subject to the terms of the Mozilla Public
4+% License, v. 2.0. If a copy of the MPL was not distributed with this
5+% file, You can obtain one at http://mozilla.org/MPL/2.0/.
6+
7+:- module turbolisp.runtime.
8+
9+%=============================================================================%
10+% TurboLisp runtime components.
11+:- interface.
12+%=============================================================================%
13+
14+:- import_module list.
15+:- use_module assoc_list.
16+:- use_module rbtree.
17+:- use_module maybe.
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 turbolisp.runtime.builtin.
187+:- use_module turbolisp.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(turbolisp__runtime__builtin__builtin_eq_bind)).
392+builtin_bind(args("!", 4), mercury_bind(turbolisp__runtime__builtin__builtin_ne_bind)).
393+builtin_bind(args("<", 4), mercury_bind(turbolisp__runtime__builtin__builtin_lt_bind)).
394+builtin_bind(args(">", 4), mercury_bind(turbolisp__runtime__builtin__builtin_gt_bind)).
395+builtin_bind(args("<=", 4), mercury_bind(turbolisp__runtime__builtin__builtin_le_bind)).
396+builtin_bind(args(">=", 4), mercury_bind(turbolisp__runtime__builtin__builtin_ge_bind)).
397+
398+builtin_bind(args("+", 2), mercury_bind(turbolisp__runtime__builtin__builtin_plus_bind)).
399+builtin_bind(args("-", 2), mercury_bind(turbolisp__runtime__builtin__builtin_minus_bind)).
400+builtin_bind(args("*", 2), mercury_bind(turbolisp__runtime__builtin__builtin_times_bind)).
401+builtin_bind(args("/", 2), mercury_bind(turbolisp__runtime__builtin__builtin_divide_bind)).
402+
403+builtin_bind(args("fn", 3), mercury_bind(turbolisp__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(turbolisp.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+ turbolisp.runtime.builtin.builtin_op_tag(Op, Tag),
518+ turbolisp.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+ turbolisp.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+ turbolisp.runtime.builtin.comparison(Cmp, A, B, CmpResult),
594+ (
595+ CmpResult = turbolisp.runtime.builtin.error(_),
596+ Result = FallbackResult
597+ ;
598+ (
599+ CmpResult = turbolisp.runtime.builtin.yes, Choice = Y
600+ ;
601+ CmpResult = turbolisp.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+ turbolisp__runtime__builtin__builtin_op_tag(
632+ turbolisp__runtime__builtin__define(Op), Tag)
633+ then
634+ (
635+ Op = turbolisp.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+ turbolisp.runtime.builtin.builtin_fn_bind(Tail, _, !Runtime)
651+ else
652+ true
653+ )
654+ ;
655+ Op = turbolisp.runtime.builtin.let
656+ ;
657+ Op = turbolisp.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+ turbolisp.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+ turbolisp.runtime.builtin.comparison(Cmp, A, B, CmpResult),
738+ (
739+ CmpResult = turbolisp.runtime.builtin.error(Error),
740+ turbolisp.runtime.builtin.comparison_tag(Cmp, Tag),
741+ Result = maybe.error(func_error(Tag, 2, Error))
742+ ;
743+ (
744+ CmpResult = turbolisp.runtime.builtin.yes, Choice = Y
745+ ;
746+ CmpResult = turbolisp.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+ turbolisp.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).