A small standalone Lisp used as a scripting language in the Z2 game engine
Revisão | 4b3a1764418e682332f903c5d4797fa370476a47 (tree) |
---|---|
Hora | 2019-11-10 05:10:50 |
Autor | AlaskanEmily <emily@alas...> |
Commiter | AlaskanEmily |
Fix line endings
@@ -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) | |
87 | 87 | ). |
\ No newline at end of file |
@@ -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). |
@@ -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 | + ). |
@@ -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 | + ). |
@@ -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). |