1 /*
2 This file is part of GNU APL, a free implementation of the
3 ISO/IEC Standard 13751, "Programming Language APL, Extended"
4
5 Copyright (C) 2008-2015 Dr. Jürgen Sauermann
6
7 This program is free software: you can redistribute it and/or modify
8 it under the terms of the GNU General Public License as published by
9 the Free Software Foundation, either version 3 of the License, or
10 (at your option) any later version.
11
12 This program is distributed in the hope that it will be useful,
13 but WITHOUT ANY WARRANTY; without even the implied warranty of
14 MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE. See the
15 GNU General Public License for more details.
16
17 You should have received a copy of the GNU General Public License
18 along with this program. If not, see <http://www.gnu.org/licenses/>.
19 */
20
21 #include "CharCell.hh"
22 #include "ComplexCell.hh"
23 #include "Error.hh"
24 #include "FloatCell.hh"
25 #include "IntCell.hh"
26 #include "LvalCell.hh"
27 #include "Output.hh"
28 #include "PointerCell.hh"
29 #include "PrintOperator.hh"
30 #include "Value.hh"
31 #include "SystemLimits.hh"
32 #include "Workspace.hh"
33
34 #include "Cell.icc"
35
36 //-----------------------------------------------------------------------------
37 void *
operator new(std::size_t s,void * pos)38 Cell::operator new(std::size_t s, void * pos)
39 {
40 return pos;
41 }
42 //-----------------------------------------------------------------------------
43 void
init_from_value(Value * value,Value & cell_owner,const char * loc)44 Cell::init_from_value(Value * value, Value & cell_owner, const char * loc)
45 {
46 if (value->is_simple_scalar())
47 {
48 value->get_ravel(0).init_other(this, cell_owner, loc);
49 }
50 else
51 {
52 new (this) PointerCell(value, cell_owner);
53 }
54 }
55 //-----------------------------------------------------------------------------
56 Value_P
to_value(const char * loc) const57 Cell::to_value(const char * loc) const
58 {
59 Value_P ret;
60 if (is_pointer_cell())
61 {
62 ret = get_pointer_value(); // ->clone(LOC);
63 }
64 else
65 {
66 ret = Value_P(loc);
67 init_other(&ret->get_ravel(0), ret.getref(), loc);
68 ret->check_value(LOC);
69 }
70
71 return ret;
72 }
73 //-----------------------------------------------------------------------------
74 void
init_type(const Cell & other,Value & cell_owner,const char * loc)75 Cell::init_type(const Cell & other, Value & cell_owner, const char * loc)
76 {
77 if (other.is_pointer_cell())
78 {
79 Q(LOC)
80 Value_P sub = other.get_pointer_value()->clone(loc);
81 Assert(!sub->is_simple_scalar());
82 sub->to_proto();
83 new (this) PointerCell(sub.get(), cell_owner);
84 }
85 else if (other.is_lval_cell())
86 {
87 new (this) LvalCell(other.get_lval_value(),
88 other.cLvalCell().get_cell_owner());
89 }
90 else if (other.is_character_cell())
91 {
92 new (this) CharCell(UNI_ASCII_SPACE);
93 }
94 else // numeric
95 {
96 new (this) IntCell(0);
97 }
98 }
99 //-----------------------------------------------------------------------------
100 void
copy(Value & val,const Cell * & src,ShapeItem count)101 Cell::copy(Value & val, const Cell * & src, ShapeItem count)
102 {
103 loop(c, count)
104 {
105 Assert1(val.more());
106 src++->init_other(val.next_ravel(), val, LOC);
107 }
108 }
109 //-----------------------------------------------------------------------------
110 bool
greater(const Cell & other) const111 Cell::greater(const Cell & other) const
112 {
113 MORE_ERROR() << "Cell::greater() : Objects of class " << get_classname()
114 << " cannot be compared";
115 DOMAIN_ERROR;
116 }
117 //-----------------------------------------------------------------------------
118 bool
equal(const Cell & other,double qct) const119 Cell::equal(const Cell & other, double qct) const
120 {
121 MORE_ERROR() << "Cell::equal() : Objects of class " << get_classname()
122 << " cannot be compared";
123 DOMAIN_ERROR;
124 }
125 //-----------------------------------------------------------------------------
126 bool
compare_stable(const Cell * const & A,const Cell * const & B,const void *)127 Cell::compare_stable(const Cell * const & A, const Cell * const & B,
128 const void *)
129 {
130 const Comp_result cr = A->compare(*B);
131 if (cr == COMP_EQ) return A < B;
132 return cr == COMP_GT;
133 }
134 //-----------------------------------------------------------------------------
135 bool
compare_ptr(const Cell * const & A,const Cell * const & B,const void *)136 Cell::compare_ptr(const Cell * const & A, const Cell * const & B,
137 const void *)
138 {
139 return A > B;
140 }
141 //-----------------------------------------------------------------------------
142 bool
is_near_int(APL_Float value)143 Cell::is_near_int(APL_Float value)
144 {
145 if (value > LARGE_INT) return true;
146 if (value < SMALL_INT) return true;
147
148 const APL_Float result = nearbyint(value);
149 const APL_Float diff = value - result;
150 if (diff >= INTEGER_TOLERANCE) return false;
151 if (diff <= -INTEGER_TOLERANCE) return false;
152
153 return true;
154 }
155 //-----------------------------------------------------------------------------
156 bool
is_near_int64_t(APL_Float value)157 Cell::is_near_int64_t(APL_Float value)
158 {
159 if (value > LARGE_INT) return false;
160 if (value < SMALL_INT) return false;
161
162 const APL_Float result = nearbyint(value);
163 const APL_Float diff = value - result;
164 if (diff >= INTEGER_TOLERANCE) return false;
165 if (diff <= -INTEGER_TOLERANCE) return false;
166
167 return true;
168 }
169 //-----------------------------------------------------------------------------
170 APL_Integer
near_int(APL_Float value)171 Cell::near_int(APL_Float value)
172 {
173 if (value >= LARGE_INT) DOMAIN_ERROR;
174 if (value <= SMALL_INT) DOMAIN_ERROR;
175
176 const APL_Float result = nearbyint(value);
177 const APL_Float diff = value - result;
178 if (diff > INTEGER_TOLERANCE) DOMAIN_ERROR;
179 if (diff < -INTEGER_TOLERANCE) DOMAIN_ERROR;
180
181 if (result > 0.0) return APL_Integer(0.3 + result);
182 else return - APL_Integer(0.3 - result);
183 }
184 //-----------------------------------------------------------------------------
185 bool
greater_vec(const IntCell & Za,const IntCell & Zb,const void * comp_arg)186 Cell::greater_vec(const IntCell & Za, const IntCell & Zb, const void * comp_arg)
187 {
188 struct _ctx { const Cell * base; ShapeItem comp_len; };
189 const _ctx * ctx = reinterpret_cast<const _ctx *>(comp_arg);
190 const Cell * ca = ctx->base + ctx->comp_len * Za.get_int_value();
191 const Cell * cb = ctx->base + ctx->comp_len * Zb.get_int_value();
192
193 const double qct = Workspace::get_CT();
194
195 // most frequently comp_len is 1, so we optimize for this case.
196 //
197 if (ctx->comp_len == 1)
198 {
199 const bool equal = ca[0].equal(cb[0], qct);
200 if (equal) return Za.get_int_value() > Zb.get_int_value();
201 const bool result = ca[0].greater(cb[0]);
202 return result;
203 }
204
205 loop(c, ctx->comp_len)
206 {
207 const bool equal = ca[c].equal(cb[c], qct);
208 if (equal) continue;
209 const bool result = ca[c].greater(cb[c]);
210 return result;
211 }
212
213 return Za.get_int_value() > Zb.get_int_value(); // a and b are equal: sort by position
214 }
215 //-----------------------------------------------------------------------------
216 bool
smaller_vec(const IntCell & Za,const IntCell & Zb,const void * comp_arg)217 Cell::smaller_vec(const IntCell & Za, const IntCell & Zb, const void * comp_arg)
218 {
219 struct _ctx { const Cell * base; ShapeItem comp_len; };
220 const _ctx * ctx = reinterpret_cast<const _ctx *>(comp_arg);
221 const Cell * ca = ctx->base + ctx->comp_len * Za.get_int_value();
222 const Cell * cb = ctx->base + ctx->comp_len * Zb.get_int_value();
223
224 const double qct = Workspace::get_CT();
225
226 // most frequently comp_len is 1, so we optimize for this case.
227 //
228 if (ctx->comp_len == 1)
229 {
230 const bool equal = ca[0].equal(cb[0], qct);
231 if (equal) return Za.get_int_value() > Zb.get_int_value();
232 const bool result = ca[0].greater(cb[0]);
233 return !result;
234 }
235
236 loop(c, ctx->comp_len)
237 {
238 const bool equal = ca[c].equal(cb[c], qct);
239 if (equal) continue;
240 const bool result = ca[c].greater(cb[c]);
241 return !result;
242 }
243
244 return Za.get_int_value() > Zb.get_int_value(); // a and b are equal: sort by position
245 }
246 //-----------------------------------------------------------------------------
247 ostream &
operator <<(ostream & out,const Cell & cell)248 operator <<(ostream & out, const Cell & cell)
249 {
250 PrintBuffer pb = cell.character_representation(PR_BOXED_GRAPHIC);
251 UCS_string ucs(pb, 0, Workspace::get_PW());
252 return out << ucs << " ";
253 }
254 //-----------------------------------------------------------------------------
255 ErrorCode
bif_equal(Cell * Z,const Cell * A) const256 Cell::bif_equal(Cell * Z, const Cell * A) const
257 {
258 // incompatible types ?
259 //
260 if (is_character_cell() != A->is_character_cell()) return IntCell::z0(Z);
261
262 return IntCell::zv(Z, equal(*A, Workspace::get_CT()));
263 }
264 //-----------------------------------------------------------------------------
265 ErrorCode
bif_not_equal(Cell * Z,const Cell * A) const266 Cell::bif_not_equal(Cell * Z, const Cell * A) const
267 {
268 // incompatible types ?
269 //
270 if (is_character_cell() != A->is_character_cell()) return IntCell::z1(Z);
271
272 return IntCell::zv(Z, !equal(*A, Workspace::get_CT()));
273 }
274 //-----------------------------------------------------------------------------
275 ErrorCode
bif_greater_than(Cell * Z,const Cell * A) const276 Cell::bif_greater_than(Cell * Z, const Cell * A) const
277 {
278 return IntCell::zv(Z, (A->compare(*this) == COMP_GT) ? 1 : 0);
279 }
280 //-----------------------------------------------------------------------------
281 ErrorCode
bif_less_eq(Cell * Z,const Cell * A) const282 Cell::bif_less_eq(Cell * Z, const Cell * A) const
283 {
284 return IntCell::zv(Z, (A->compare(*this) != COMP_GT) ? 1 : 0);
285 }
286 //-----------------------------------------------------------------------------
287 ErrorCode
bif_less_than(Cell * Z,const Cell * A) const288 Cell::bif_less_than(Cell * Z, const Cell * A) const
289 {
290 return IntCell::zv(Z, (A->compare(*this) == COMP_LT) ? 1 : 0);
291 }
292 //-----------------------------------------------------------------------------
293 ErrorCode
bif_greater_eq(Cell * Z,const Cell * A) const294 Cell::bif_greater_eq(Cell * Z, const Cell * A) const
295 {
296 return IntCell::zv(Z, (A->compare(*this) != COMP_LT) ? 1 : 0);
297 }
298 //-----------------------------------------------------------------------------
299