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-2017 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 <sys/types.h>
22 #include <vector>
23
24 #include "CDR_string.hh"
25 #include "CharCell.hh"
26 #include "ComplexCell.hh"
27 #include "Common.hh"
28 #include "Error.hh"
29 #include "FloatCell.hh"
30 #include "IndexExpr.hh"
31 #include "IndexIterator.hh"
32 #include "IntCell.hh"
33 #include "IO_Files.hh"
34 #include "LvalCell.hh"
35 #include "Macro.hh"
36 #include "Output.hh"
37 #include "PointerCell.hh"
38 #include "Parallel.hh"
39 #include "PrintOperator.hh"
40 #include "SystemVariable.hh"
41 #include "UCS_string.hh"
42 #include "UserFunction.hh"
43 #include "Value.hh"
44 #include "ValueHistory.hh"
45 #include "Workspace.hh"
46
47 extern uint64_t top_of_memory();
48
49 uint64_t Value::value_count = 0;
50 uint64_t Value::total_ravel_count = 0;
51
52 // the static Value instances are defined in StaticObjects.cc
53
54 _deleted_value * Value::deleted_values = 0;
55 int Value::deleted_values_count = 0;
56 uint64_t Value::fast_new = 0;
57 uint64_t Value::slow_new = 0;
58 uint64_t Value::alloc_size = 0;
59
60
61 //-----------------------------------------------------------------------------
62 void
init_ravel()63 Value::init_ravel()
64 {
65 owner_count = 0;
66 pointer_cell_count = 0;
67 nz_subcell_count = 0;
68 check_ptr = 0;
69 new (short_value) IntCell(0);
70 ravel = short_value;
71
72 ++value_count;
73 if (Quad_SYL::value_count_limit &&
74 Quad_SYL::value_count_limit < APL_Integer(value_count))
75 {
76 MORE_ERROR() <<
77 "the system limit on the APL value count (as set in ⎕SYL) was reached\n"
78 "(and to avoid lock-up, the limit in ⎕SYL was automatically cleared).";
79
80 // reset the limit so that we don't get stuck here.
81 //
82 Quad_SYL::value_count_limit = 0;
83 set_attention_raised(LOC);
84 set_interrupt_raised(LOC);
85 }
86
87 const ShapeItem length = shape.get_volume();
88
89 // small values always succeed...
90 //
91 if (length <= SHORT_VALUE_LENGTH_WANTED)
92 {
93 check_ptr = charP(this) + 7;
94 return;
95 }
96
97 // large Value. If the compiler uses 4-byte pointers, then do not allow APL
98 // values that are too large. The reason is that new[] may return
99 // a non-0 pointer (thus pretending everything is OK), but a subsequent
100 // attempt to initialize the value might then throw a segfault.
101 //
102 enum { MAX_LEN = 2000000000 / sizeof(Cell) };
103 if (length > MAX_LEN && sizeof(void *) < 6)
104 throw_apl_error(E_WS_FULL, alloc_loc);
105
106 if (Quad_SYL::ravel_count_limit &&
107 Quad_SYL::ravel_count_limit < APL_Integer(total_ravel_count + length))
108 {
109 // make sure that the value is properly initialized
110 //
111 new (&shape) Shape();
112 ravel = short_value;
113 new (ravel) IntCell(42);
114
115 MORE_ERROR() <<
116 "the system limit on the total ravel size (as set in ⎕SYL) was reached\n"
117 "(and to avoid lock-up, the limit in ⎕SYL was automatically cleared).";
118
119 // reset the limit so that we don't get stuck here.
120 //
121 Quad_SYL::ravel_count_limit = 0;
122 set_attention_raised(LOC);
123 set_interrupt_raised(LOC);
124 }
125
126 alloc_size = length * sizeof(Cell);
127 ravel = reinterpret_cast<Cell *>(new char[alloc_size]);
128
129 /*
130 ravel = 0; // assume new() fails
131 // try
132 // {
133 ravel = reinterpret_cast<Cell *>(new char[length * sizeof(Cell)]);
134 if (ravel == 0) // new failed (without trowing an exception)
135 {
136 Log(LOG_Value_alloc)
137 CERR << "new char[" << (length * sizeof(Cell))
138 << "] (aka. long ravel allocation) returned 0 at " LOC
139 << endl;
140
141 MORE_ERROR() << "The instatiation of a Value object succeeded, "
142 "but allocation of its (large) ravel failed.";
143 new (&shape) Shape();
144 ravel = short_value;
145 throw_apl_error(E_WS_FULL, alloc_loc);
146 }
147 }
148 catch (...)
149 {
150 // for some unknown reason, this object gets cleared after
151 // throwing the E_WS_FULL below (which destroys the prev and
152 // next pointers. We therefore unlink() the object here (where
153 // prev and next pointers are still intact).
154 //
155 unlink();
156
157 Log(LOG_Value_alloc)
158 {
159 CERR << "new char[" << (length * sizeof(Cell))
160 << "] (aka. long ravel allocation) threw an exception at " LOC
161 << endl;
162 }
163
164 MORE_ERROR() << "The instatiation of a Value object succeeded, "
165 "but allocation of its (large) ravel failed.";
166 new (&shape) Shape();
167 ravel = short_value;
168 throw_apl_error(E_WS_FULL, alloc_loc);
169 }
170 */
171
172 // init the first ravel element to (prototype) 0 so that we can avoid
173 // many empty checks all over the place
174 //
175 new (ravel) IntCell(0);
176 check_ptr = charP(this) + 7;
177 total_ravel_count += length;
178 }
179 //-----------------------------------------------------------------------------
180 bool
check_WS_FULL(const char * args,ShapeItem requested_cell_count,const char * loc)181 Value::check_WS_FULL(const char * args, ShapeItem requested_cell_count,
182 const char * loc)
183 {
184 const int64_t used_memory
185 = (total_ravel_count + requested_cell_count) * sizeof(Cell)
186 + (value_count + 1) * sizeof(Value)
187 + Workspace::SI_entry_count() * sizeof(StateIndicator);
188
189 if ((Quad_WA::total_memory*Quad_WA::WA_scale/100) >
190 (used_memory + Quad_WA::WA_margin)) return false; // OK
191
192 Log(LOG_Value_alloc) CERR
193 << " value_count: " << value_count << endl
194 << " total_ravel_count: " << total_ravel_count << " cells" << endl
195 << " new cell_count: " << requested_cell_count << " cells" << endl
196 << " total_memory: " << Quad_WA::total_memory << " bytes" << endl
197 << " used_memory: " << used_memory << " bytes" << endl
198 << " ⎕WA margin: " << Quad_WA::WA_margin << " bytes" << endl
199 << " ⎕WA scale: " << Quad_WA::WA_scale << "%" << endl
200
201 << " at " << LOC << endl;
202 return true;
203 }
204 //-----------------------------------------------------------------------------
205 void
catch_Error(const Error & error,const char * args,const char * loc)206 Value::catch_Error(const Error & error, const char * args, const char * loc)
207 {
208 Log(LOG_Value_alloc) CERR << "Ravel allocation failed" << endl;
209 MORE_ERROR() << "new Value(" << args
210 << ") failed (APL error in ravel allocation)";
211 throw error; // rethrow
212 }
213 //-----------------------------------------------------------------------------
214 void
catch_exception(const exception & ex,const char * args,const char * caller,const char * loc)215 Value::catch_exception(const exception & ex, const char * args,
216 const char * caller, const char * loc)
217 {
218 const int64_t used_memory
219 = total_ravel_count * sizeof(Cell)
220 + value_count * sizeof(Value)
221 + Workspace::SI_entry_count() * sizeof(StateIndicator);
222
223 CERR << "Value_P::Value_P(" << args << ") failed at " << loc
224 << " (caller: " << caller << ")" << endl
225 << " what: " << ex.what() << endl
226 << " initial sbrk(): 0x" << hex << Quad_WA::initial_sbrk << endl
227 << " current sbrk(): 0x" << top_of_memory() << endl
228 << " alloc_size: 0x" << alloc_size << dec << " ("
229 << alloc_size << ")" << endl
230 << " used memory: 0x" << hex << used_memory << dec
231 << " (" << used_memory << ")" << endl;
232
233 MORE_ERROR() << "new Value(" << args << ") failed (" << ex.what() << ")";
234 WS_FULL;
235 }
236 //-----------------------------------------------------------------------------
237 void
catch_ANY(const char * args,const char * caller,const char * loc)238 Value::catch_ANY(const char * args, const char * caller, const char * loc)
239 {
240 Log(LOG_Value_alloc)
241 CERR << "Value_P::Value_P(Shape " << args << " failed at " << loc
242 << " (caller: " << caller << ")" << endl;
243 MORE_ERROR() << "new Value(" << args << ") failed (ANY)";
244 WS_FULL;
245 }
246 //-----------------------------------------------------------------------------
Value(const char * loc)247 Value::Value(const char * loc)
248 : DynamicObject(loc, &all_values),
249 flags(VF_NONE),
250 valid_ravel_items(0)
251 {
252 ADD_EVENT(this, VHE_Create, 0, loc);
253 init_ravel();
254 }
255 //-----------------------------------------------------------------------------
Value(const Cell & cell,const char * loc)256 Value::Value(const Cell & cell, const char * loc)
257 : DynamicObject(loc, &all_values),
258 flags(VF_NONE),
259 valid_ravel_items(0)
260 {
261 ADD_EVENT(this, VHE_Create, 0, loc);
262 init_ravel();
263
264 get_ravel(0).init(cell, *this, loc);
265 check_value(LOC);
266 }
267 //-----------------------------------------------------------------------------
Value(ShapeItem sh,const char * loc)268 Value::Value(ShapeItem sh, const char * loc)
269 : DynamicObject(loc, &all_values),
270 shape(sh),
271 flags(VF_NONE),
272 valid_ravel_items(0)
273 {
274 ADD_EVENT(this, VHE_Create, 0, loc);
275 init_ravel();
276 }
277 //-----------------------------------------------------------------------------
Value(const Shape & sh,const char * loc)278 Value::Value(const Shape & sh, const char * loc)
279 : DynamicObject(loc, &all_values),
280 shape(sh),
281 flags(VF_NONE),
282 valid_ravel_items(0)
283 {
284 ADD_EVENT(this, VHE_Create, 0, loc);
285 init_ravel();
286 }
287 //-----------------------------------------------------------------------------
Value(const UCS_string & ucs,const char * loc)288 Value::Value(const UCS_string & ucs, const char * loc)
289 : DynamicObject(loc, &all_values),
290 shape(ucs.size()),
291 flags(VF_NONE),
292 valid_ravel_items(0)
293 {
294 ADD_EVENT(this, VHE_Create, 0, loc);
295 init_ravel();
296
297 new (&get_ravel(0)) CharCell(UNI_ASCII_SPACE); // prototype
298 loop(l, ucs.size()) new (next_ravel()) CharCell(ucs[l]);
299 set_complete();
300 }
301 //-----------------------------------------------------------------------------
Value(const UTF8_string & utf,const char * loc)302 Value::Value(const UTF8_string & utf, const char * loc)
303 : DynamicObject(loc, &all_values),
304 shape(utf.size()),
305 flags(VF_NONE),
306 valid_ravel_items(0)
307 {
308 ADD_EVENT(this, VHE_Create, 0, loc);
309 init_ravel();
310
311 new (&get_ravel(0)) CharCell(UNI_ASCII_SPACE); // prototype
312 loop(l, utf.size())
313 new (next_ravel()) CharCell(Unicode(utf[l] & 0xFF));
314 set_complete();
315 }
316 //-----------------------------------------------------------------------------
Value(const CDR_string & ui8,const char * loc)317 Value::Value(const CDR_string & ui8, const char * loc)
318 : DynamicObject(loc, &all_values),
319 shape(ui8.size()),
320 flags(VF_NONE),
321 valid_ravel_items(0)
322 {
323 ADD_EVENT(this, VHE_Create, 0, loc);
324 init_ravel();
325
326 new (&get_ravel(0)) CharCell(UNI_ASCII_SPACE); // prototype
327 loop(l, ui8.size()) new (next_ravel()) CharCell(Unicode(ui8[l]));
328 set_complete();
329 }
330 //-----------------------------------------------------------------------------
Value(const PrintBuffer & pb,const char * loc)331 Value::Value(const PrintBuffer & pb, const char * loc)
332 : DynamicObject(loc, &all_values),
333 shape(pb.get_height(), pb.get_width(0)),
334 flags(VF_NONE),
335 valid_ravel_items(0)
336 {
337 ADD_EVENT(this, VHE_Create, 0, loc);
338 init_ravel();
339
340 new (&get_ravel(0)) CharCell(UNI_ASCII_SPACE); // prototype
341
342 const ShapeItem height = pb.get_height();
343 const ShapeItem width = pb.get_width(0);
344
345 loop(y, height)
346 loop(x, width) next_ravel()->init(CharCell(pb.get_char(x, y)), *this, loc);
347
348 set_complete();
349 }
350 //-----------------------------------------------------------------------------
Value(const char * loc,const Shape * sh)351 Value::Value(const char * loc, const Shape * sh)
352 : DynamicObject(loc, &all_values),
353 shape(ShapeItem(sh->get_rank())),
354 flags(VF_NONE),
355 valid_ravel_items(0)
356 {
357 ADD_EVENT(this, VHE_Create, 0, loc);
358 init_ravel();
359
360 get_ravel(0).init(IntCell(0), *this, loc); // prototype
361
362 loop(r, sh->get_rank())
363 next_ravel()->init(IntCell(sh->get_shape_item(r)), *this, loc);
364
365 set_complete();
366 }
367 //-----------------------------------------------------------------------------
~Value()368 Value::~Value()
369 {
370 ADD_EVENT(this, VHE_Destruct, 0, LOC);
371 unlink();
372
373 const ShapeItem length = nz_element_count();
374
375 #if !APL_Float_is_class
376 // APL_Float is NOT a class, Therefore release only PointerCells
377 if (get_pointer_cell_count() > 0)
378 #endif
379 {
380 Cell * cZ = &get_ravel(0);
381 if (is_complete()) // OK to release
382 {
383 loop(c, length) cZ++->release(LOC);
384 }
385 else
386 {
387 // the last ravel item could be corrupt
388 loop(c, valid_ravel_items - 1) cZ++->release(LOC);
389 }
390
391 }
392
393 --value_count;
394
395 if (ravel == 0) return; // new() failed
396
397 if (ravel != short_value) // long value
398 {
399 total_ravel_count -= length;
400 delete [] ravel;
401 }
402
403 Assert(check_ptr == charP(this) + 7);
404 check_ptr = 0;
405 }
406 //-----------------------------------------------------------------------------
407 Value_P
get_cellrefs(const char * loc)408 Value::get_cellrefs(const char * loc)
409 {
410 Value_P ret(get_shape(), loc);
411
412 const ShapeItem ec = element_count();
413
414 loop(e, ec)
415 {
416 Cell & cell = get_ravel(e);
417 new (ret->next_ravel()) LvalCell(&cell, this);
418 }
419
420 // prototype
421 if (ec == 0) new (&ret->get_ravel(0)) LvalCell(&get_ravel(0), this);
422
423 ret->check_value(LOC);
424 return ret;
425 }
426 //-----------------------------------------------------------------------------
427 void
assign_cellrefs(Value_P new_value)428 Value::assign_cellrefs(Value_P new_value)
429 {
430 const ShapeItem dest_count = nz_element_count();
431 const ShapeItem value_count = new_value->nz_element_count();
432 const Cell * src = &new_value->get_ravel(0);
433 Cell * C = &get_ravel(0);
434
435 // this: a value containing LvalCells and possibly PointerCells.
436 // cellowner: the owner of the cells that this points to
437 //
438 Value * cellowner = get_lval_cellowner();
439
440 const int src_incr = new_value->is_scalar() ? 0 : 1;
441
442 // if this is a scalar and new_value is not, then enclose new_value
443 //
444 if (is_scalar() && !new_value->is_scalar())
445 {
446 if (!C->is_lval_cell()) LEFT_SYNTAX_ERROR;
447
448 Cell * dest = C->get_lval_value(); // can be 0!
449 if (dest) dest->release(LOC); // free sub-values etc (if any)
450
451 new (dest) PointerCell(new_value.get(), *cellowner);
452 return;
453 }
454
455 // at this point both this and new_value should have the same number
456 // of elements
457 //
458 if (!new_value->is_scalar() && value_count != dest_count) LENGTH_ERROR;
459
460 loop(d, dest_count)
461 {
462 if (!C->is_lval_cell()) LEFT_SYNTAX_ERROR;
463
464 if (Cell * dest = C++->get_lval_value()) // dest can be 0!
465 {
466 dest->release(LOC); // free sub-values etc (if any)
467
468 // erase the pointee when overriding a pointer-cell.
469 //
470 dest->init(*src, *cellowner, LOC);
471 }
472 src += src_incr;
473 }
474 }
475 //-----------------------------------------------------------------------------
476 Value *
get_lval_cellowner() const477 Value::get_lval_cellowner() const
478 {
479 const ShapeItem ec = nz_element_count();
480
481 // find the first lval cell with a non-0 owner
482 //
483 loop(e, ec)
484 {
485 const Cell & cell = get_ravel(e);
486 if (cell.is_lval_cell())
487 return cell.cLvalCell().get_cell_owner();
488
489 if (cell.is_pointer_cell())
490 return cell.get_pointer_value()->get_lval_cellowner();
491 }
492
493 return 0;
494 }
495 //-----------------------------------------------------------------------------
496 bool
is_or_contains(const Value * val,const Value & sub)497 Value::is_or_contains(const Value * val, const Value & sub)
498 {
499 if (val == 0) return false; // not a valid value
500
501 if (val == &sub) return true;
502
503 const Cell * C = &val->get_ravel(0);
504 loop(e, val->nz_element_count())
505 {
506 if (C->is_pointer_cell())
507 {
508 if (is_or_contains(C->get_pointer_value().get(), sub))
509 return true;
510 }
511 ++C;
512 }
513
514 return false;
515 }
516 //-----------------------------------------------------------------------------
517 void
flag_info(const char * loc,ValueFlags flag,const char * flag_name,bool set) const518 Value::flag_info(const char * loc, ValueFlags flag, const char * flag_name,
519 bool set) const
520 {
521 const char * sc = set ? " SET " : " CLEAR ";
522 const int new_flags = set ? flags | flag : flags & ~flag;
523 const char * chg = flags == new_flags ? " (no change)" : " (changed)";
524
525 CERR << "Value " << voidP(this)
526 << sc << flag_name << " (" << HEX(flag) << ")"
527 << " at " << loc << " now = " << HEX(new_flags)
528 << chg << endl;
529 }
530 //-----------------------------------------------------------------------------
531 void
init()532 Value::init()
533 {
534 Log(LOG_startup)
535 CERR << "Max. Rank is " << MAX_RANK << endl
536 << "sizeof(Value header) is " << sizeof(Value) << " bytes" << endl
537 << "Cell size is " << sizeof(Cell) << " bytes" << endl;
538 };
539 //-----------------------------------------------------------------------------
540 void
mark_all_dynamic_values()541 Value::mark_all_dynamic_values()
542 {
543 for (DynamicObject * dob = DynamicObject::all_values.get_prev();
544 dob != &all_values; dob = dob->get_prev())
545 {
546 dob->pValue()->set_marked();
547 }
548 }
549 //-----------------------------------------------------------------------------
550 void
unmark() const551 Value::unmark() const
552 {
553 clear_marked();
554
555 const ShapeItem ec = nz_element_count();
556 const Cell * C = &get_ravel(0);
557 loop(e, ec)
558 {
559 if (C->is_pointer_cell()) C->get_pointer_value()->unmark();
560 ++C;
561 }
562 }
563 //-----------------------------------------------------------------------------
564 void
rollback(ShapeItem items,const char * loc)565 Value::rollback(ShapeItem items, const char * loc)
566 {
567 ADD_EVENT(this, VHE_Unroll, 0, loc);
568
569 // this value has only items < nz_element_count() valid items.
570 // init the rest...
571 //
572 while (items < nz_element_count()) new (&get_ravel(items++)) IntCell(0);
573
574 const_cast<Value *>(this)->alloc_loc = loc;
575 }
576 //-----------------------------------------------------------------------------
577 void
erase_all(ostream & out)578 Value::erase_all(ostream & out)
579 {
580 for (const DynamicObject * dob = DynamicObject::all_values.get_next();
581 dob != &DynamicObject::all_values; dob = dob->get_next())
582 {
583 const Value * v = dob->pValue();
584 out << "erase_all sees Value:" << endl
585 << " Allocated by " << v->where_allocated() << endl
586 << " ";
587 v->list_one(CERR, false);
588 }
589 }
590 //-----------------------------------------------------------------------------
591 int
erase_stale(const char * loc)592 Value::erase_stale(const char * loc)
593 {
594 int count = 0;
595
596 Log(LOG_Value__erase_stale)
597 CERR << endl << endl << "erase_stale() called from " << loc << endl;
598
599 for (DynamicObject * dob = all_values.get_next();
600 dob != &all_values; dob = dob->get_next())
601 {
602 Value * v = dob->pValue();
603 if (dob == dob->get_next()) // a loop
604 {
605 CERR << "A loop in DynamicObject::all_values (detected in "
606 "function erase_stale() at object "
607 << voidP(dob) << "): " << endl;
608 all_values.print_chain(CERR);
609 CERR << endl;
610
611 CERR << " DynamicObject: " << dob << endl;
612 CERR << " Value: " << v << endl;
613 CERR << *v << endl;
614 }
615
616 Assert(dob != dob->get_next());
617 if (v->owner_count) continue;
618
619 ADD_EVENT(v, VHE_Stale, v->owner_count, loc);
620
621 Log(LOG_Value__erase_stale)
622 {
623 CERR << "Erasing stale Value "
624 << voidP(dob) << ":" << endl
625 << " Allocated by " << v->where_allocated() << endl
626 << " ";
627 v->list_one(CERR, false);
628 }
629
630 // count it unless we know it is dirty
631 //
632 ++count;
633
634 dob->unlink();
635
636 // v->erase(loc) could mess up the chain, so we start over
637 // rather than continuing
638 //
639 dob = &all_values;
640 }
641
642 return count;
643 }
644 //-----------------------------------------------------------------------------
645 int
finish_incomplete(const char * loc)646 Value::finish_incomplete(const char * loc)
647 {
648 // finish_incomplete() is called when a function, typically one of the
649 // StateIndicator::eval_XXX() functions, has thrown an error.
650 // The value has been constructed, its shape is correct, but some (or all)
651 // of the ravel cells are uninitialized. The VF_complete bit of such
652 // values is not set.
653 //
654 // We fix this by initializing the entire ravel to 42424242. The value
655 // probably remains stale, though. Deleting it here could cause double-
656 // delete problems, so we rather set the dirty bit.
657 //
658 int count = 0;
659
660 Log(LOG_Value__erase_stale)
661 {
662 CERR << endl << endl
663 << "finish_incomplete() called from " << loc << endl;
664 }
665
666 for (DynamicObject * dob = all_values.get_next();
667 dob != &all_values; dob = dob->get_next())
668 {
669 Value * v = dob->pValue();
670 if (dob == dob->get_next()) // a loop
671 {
672 CERR << "A loop in DynamicObject::all_values (detected in "
673 "function Value::finish_incomplete() at object "
674 << voidP(dob) << "): " << endl;
675 all_values.print_chain(CERR);
676 CERR << endl;
677
678 CERR << " DynamicObject: " << dob << endl;
679 CERR << " Value: " << v << endl;
680 CERR << *v << endl;
681 }
682
683 Assert(dob != dob->get_next());
684 if (v->flags & VF_complete) continue;
685
686 ADD_EVENT(v, VHE_Completed, v->owner_count, LOC);
687
688 ShapeItem ravel_length = v->nz_element_count();
689 Cell * cv = &v->get_ravel(0);
690 loop(r, ravel_length) new (cv++) IntCell(42424242);
691 v->set_complete();
692
693 Log(LOG_Value__erase_stale)
694 {
695 CERR << "Fixed incomplete Value "
696 << voidP(dob) << ":" << endl
697 << " Allocated by " << v->where_allocated() << endl
698 << " ";
699 v->list_one(CERR, false);
700 }
701
702 ++count;
703 }
704
705 return count;
706 }
707 //-----------------------------------------------------------------------------
708 ostream &
list_one(ostream & out,bool show_owners) const709 Value::list_one(ostream & out, bool show_owners) const
710 {
711 if (flags)
712 {
713 out << " Flags =";
714 char sep = ' ';
715 if (is_complete()) { out << sep << "COMPLETE"; sep = '+'; }
716 if (is_marked()) { out << sep << "MARKED"; sep = '+'; }
717 }
718 else
719 {
720 out << " Flags = NONE";
721 }
722
723 out << ", ⍴" << get_shape() << " ≡" << compute_depth() << ":" << endl;
724 print(out);
725 out << endl;
726
727 if (!show_owners) return out;
728
729 // print owners...
730 //
731 out << "Owners of " << voidP(this) << ":" << endl;
732
733 Workspace::show_owners(out, *this);
734
735 out << "---------------------------" << endl << endl;
736 return out;
737 }
738 //-----------------------------------------------------------------------------
739 ostream &
list_all(ostream & out,bool show_owners)740 Value::list_all(ostream & out, bool show_owners)
741 {
742 int num = 0;
743 for (const DynamicObject * dob = all_values.get_prev();
744 dob != &all_values; dob = dob->get_prev())
745 {
746 out << "Value #" << num++ << ":";
747 dob->pValue()->list_one(out, show_owners);
748 }
749
750 return out << endl;
751 }
752 //-----------------------------------------------------------------------------
753 ShapeItem
get_enlist_count() const754 Value::get_enlist_count() const
755 {
756 const ShapeItem ec = element_count();
757 ShapeItem count = ec;
758
759 loop(c, ec)
760 {
761 const Cell & cell = get_ravel(c);
762 if (cell.is_pointer_cell())
763 {
764 count--; // the pointer cell
765 count += cell.get_pointer_value()->get_enlist_count();
766 }
767 else if (cell.is_lval_cell())
768 {
769 Cell * cp = cell.get_lval_value();
770 if (cp && cp->is_pointer_cell())
771 {
772 count--;
773 count += cp->get_pointer_value()->get_enlist_count();
774 }
775 }
776 }
777
778 return count;
779 }
780 //-----------------------------------------------------------------------------
781 void
enlist(Cell * & dest,Value & dest_owner,bool left) const782 Value::enlist(Cell * & dest, Value & dest_owner, bool left) const
783 {
784 ShapeItem ec = element_count();
785
786 loop(c, ec)
787 {
788 const Cell & cell = get_ravel(c);
789 if (cell.is_pointer_cell())
790 {
791 cell.get_pointer_value()->enlist(dest, dest_owner, left);
792 }
793 else if (left && cell.is_lval_cell())
794 {
795 const Cell * cp = cell.get_lval_value();
796 if (cp == 0)
797 {
798 CERR << "0-pointer at " LOC << endl;
799 }
800 else if (cp->is_pointer_cell())
801 {
802 cp->get_pointer_value()->enlist(dest, dest_owner, left);
803 }
804 else
805 {
806 new (dest++) LvalCell(cell.get_lval_value(), &dest_owner);
807 }
808 }
809 else if (left)
810 {
811 new (dest++)
812 LvalCell(const_cast<Cell *>(&cell), &dest_owner);
813 }
814 else
815 {
816 dest++->init(cell, dest_owner, LOC);
817 }
818 }
819 }
820 //-----------------------------------------------------------------------------
821 bool
is_apl_char_vector() const822 Value::is_apl_char_vector() const
823 {
824 if (get_rank() != 1) return false;
825
826 loop(c, get_shape_item(0))
827 {
828 if (!get_ravel(c).is_character_cell()) return false;
829
830 const Unicode uni = get_ravel(c).get_char_value();
831 if (Avec::find_char(uni) == Invalid_CHT) return false; // not in ⎕AV
832 }
833 return true;
834 }
835 //-----------------------------------------------------------------------------
836 bool
is_char_array() const837 Value::is_char_array() const
838 {
839 const Cell * C = &get_ravel(0);
840 loop(c, nz_element_count()) // also check prototype
841 if (!C++->is_character_cell()) return false; // not char
842 return true;
843 }
844 //-----------------------------------------------------------------------------
845 bool
NOTCHAR() const846 Value::NOTCHAR() const
847 {
848 // always test element 0.
849 if (!get_ravel(0).is_character_cell()) return true;
850
851 const ShapeItem ec = element_count();
852 loop(c, ec) if (!get_ravel(c).is_character_cell()) return true;
853
854 // all items are single chars.
855 return false;
856 }
857 //-----------------------------------------------------------------------------
858 int
toggle_UCS()859 Value::toggle_UCS()
860 {
861 const ShapeItem ec = nz_element_count();
862 int error_count = 0;
863
864 loop(e, ec)
865 {
866 Cell & cell = get_ravel(e);
867 if (cell.is_character_cell())
868 {
869 new (&cell) IntCell(Unicode(cell.get_char_value()));
870 }
871 else if (cell.is_integer_cell())
872 {
873 new (&cell) CharCell(Unicode(cell.get_int_value()));
874 }
875 else if (cell.is_pointer_cell())
876 {
877 error_count += cell.get_pointer_value()->toggle_UCS();
878 }
879 else
880 {
881 ++error_count;
882 }
883 }
884
885 return error_count;
886 }
887 //-----------------------------------------------------------------------------
888 bool
is_int_vector() const889 Value::is_int_vector() const
890 {
891 if (get_rank() != 1) return false;
892
893 loop(c, get_shape_item(0))
894 {
895 const Cell & cell = get_ravel(c);
896 if (!cell.is_near_int()) return false;
897 }
898
899 return true;
900 }
901 //-----------------------------------------------------------------------------
902 bool
is_complex(bool check_numeric) const903 Value::is_complex(bool check_numeric) const
904 {
905 const ShapeItem ec = nz_element_count();
906
907 loop(e, ec)
908 {
909 const Cell & cell = get_ravel(e);
910 if (!cell.is_numeric())
911 {
912 if (check_numeric) DOMAIN_ERROR;
913 else continue;
914 }
915 if (!cell.is_near_real()) return true;
916 }
917
918 return false; // all cells numeric and not complex
919 }
920 //-----------------------------------------------------------------------------
921 bool
can_be_compared() const922 Value::can_be_compared() const
923 {
924 const ShapeItem count = nz_element_count();
925 loop(c, count)
926 {
927 const Cell & cell = get_ravel(c);
928 const CellType ctype = cell.get_cell_type();
929 if (ctype & (CT_CHAR | CT_INT | CT_FLOAT)) continue;
930 if (cell.is_near_real()) continue;
931 if (cell.is_pointer_cell() &&
932 cell.get_pointer_value()->can_be_compared()) continue;
933 return false;
934 }
935
936 return true;
937 }
938 //-----------------------------------------------------------------------------
939 bool
is_simple() const940 Value::is_simple() const
941 {
942 const ShapeItem count = element_count();
943 const Cell * C = &get_ravel(0);
944
945 loop(c, count)
946 {
947 if (C->is_pointer_cell()) return false;
948 if (C->is_lval_cell()) return false;
949 ++C;
950 }
951
952 return true;
953 }
954 //-----------------------------------------------------------------------------
955 bool
is_one_dimensional() const956 Value::is_one_dimensional() const
957 {
958 // lrm would not return false if the value itself is, e.g. a matrix.
959 // That is wrong, however
960 //
961 if (get_rank() > 1) return false;
962
963 const ShapeItem count = nz_element_count();
964 const Cell * C = &get_ravel(0);
965
966 loop(c, count)
967 {
968 if (C->is_pointer_cell())
969 {
970 Value_P sub_val = C->get_pointer_value();
971 if (sub_val->get_rank() > 1) return false;
972 if (!sub_val->is_one_dimensional()) return false;
973 }
974 ++C;
975 }
976
977 return true; // all items are scalars or vectors
978 }
979 //-----------------------------------------------------------------------------
980 Depth
compute_depth() const981 Value::compute_depth() const
982 {
983 if (is_scalar())
984 {
985 if (get_ravel(0).is_pointer_cell())
986 {
987 Depth d = get_ravel(0).get_pointer_value()->compute_depth();
988 return 1 + d;
989 }
990
991 return 0;
992 }
993
994 const ShapeItem count = nz_element_count();
995
996 Depth sub_depth = 0;
997 loop(c, count)
998 {
999 Depth d = 0;
1000 if (get_ravel(c).is_pointer_cell())
1001 {
1002 d = get_ravel(c).get_pointer_value()->compute_depth();
1003 }
1004 if (sub_depth < d) sub_depth = d;
1005 }
1006
1007 return sub_depth + 1;
1008 }
1009 //-----------------------------------------------------------------------------
1010 CellType
flat_cell_types() const1011 Value::flat_cell_types() const
1012 {
1013 int32_t ctypes = 0;
1014
1015 const ShapeItem count = nz_element_count();
1016 loop(c, count) ctypes |= get_ravel(c).get_cell_type();
1017
1018 return CellType(ctypes);
1019 }
1020 //-----------------------------------------------------------------------------
1021 CellType
flat_cell_subtypes() const1022 Value::flat_cell_subtypes() const
1023 {
1024 int32_t ctypes = 0;
1025
1026 const ShapeItem count = nz_element_count();
1027 loop(c, count) ctypes |= get_ravel(c).get_cell_subtype();
1028
1029 return CellType(ctypes);
1030 }
1031 //-----------------------------------------------------------------------------
1032 CellType
deep_cell_types() const1033 Value::deep_cell_types() const
1034 {
1035 int32_t ctypes = 0;
1036
1037 const ShapeItem count = nz_element_count();
1038 loop(c, count)
1039 {
1040 const Cell & cell = get_ravel(c);
1041 ctypes |= cell.get_cell_type();
1042 if (cell.is_pointer_cell())
1043 ctypes |= cell.get_pointer_value()->deep_cell_types();
1044 }
1045
1046 return CellType(ctypes);
1047 }
1048 //-----------------------------------------------------------------------------
1049 CellType
deep_cell_subtypes() const1050 Value::deep_cell_subtypes() const
1051 {
1052 int32_t ctypes = 0;
1053
1054 const ShapeItem count = nz_element_count();
1055 loop(c, count)
1056 {
1057 const Cell & cell = get_ravel(c);
1058 ctypes |= cell.get_cell_subtype();
1059 if (cell.is_pointer_cell())
1060 ctypes |= cell.get_pointer_value()->deep_cell_subtypes();
1061 }
1062
1063 return CellType(ctypes);
1064 }
1065 //-----------------------------------------------------------------------------
1066 Value_P
index(const IndexExpr & IX) const1067 Value::index(const IndexExpr & IX) const
1068 {
1069 Assert(IX.value_count() != 1); // should have called index(Value_P X)
1070
1071 if (get_rank() != IX.value_count()) RANK_ERROR; // ISO p. 158
1072
1073 // Notes:
1074 //
1075 // 1. IX is parsed from right to left: B[I2;I1;I0] --> I0 I1 I2
1076 // the shapes of this and IX are then related as follows:
1077 //
1078 // this IX
1079 // ---------------
1080 // 0 rank-1 (rank = IX->value_count())
1081 // 1 rank-2
1082 // ... ...
1083 // rank-2 1
1084 // rank-1 0
1085 // ---------------
1086 //
1087 // 2. shape Z is the concatenation of all shapes in IX
1088 // 3. rank Z is the sum of all ranks in IX
1089
1090 // construct result rank_Z and shape_Z.
1091 // We go from higher indices of IX to lower indices (Note 1.)
1092 //
1093 Shape shape_Z;
1094 loop(this_r, get_rank())
1095 {
1096 const ShapeItem idx_r = get_rank() - this_r - 1;
1097
1098 Value_P I = IX.values[idx_r];
1099 if (!!I)
1100 {
1101 loop(s, I->get_rank())
1102 shape_Z.add_shape_item(I->get_shape_item(s));
1103 }
1104 else
1105 {
1106 shape_Z.add_shape_item(this->get_shape_item(this_r));
1107 }
1108 }
1109
1110 // check that all indices are valid
1111 //
1112 if (IX.check_range(get_shape()))
1113 {
1114 INDEX_ERROR;
1115 }
1116
1117 MultiIndexIterator mult(get_shape(), IX);
1118
1119 Value_P Z(shape_Z, LOC);
1120 const ShapeItem ec_z = Z->element_count();
1121
1122 if (ec_z == 0) // empty result
1123 {
1124 Z->set_default(*this, LOC);
1125 Z->check_value(LOC);
1126 return Z;
1127 }
1128
1129 // construct iterators.
1130 // We go from lower indices to higher indices in IX, which
1131 // means from higher indices to lower indices in this and Z
1132 //
1133 loop(z, ec_z)
1134 Z->next_ravel()->init(get_ravel(mult++), Z.getref(), LOC);
1135
1136 Assert(!mult.more());
1137 Z->check_value(LOC);
1138 return Z;
1139 }
1140 //-----------------------------------------------------------------------------
1141 Value_P
index(Value_P X) const1142 Value::index(Value_P X) const
1143 {
1144 const ShapeItem max_idx = element_count();
1145 const APL_Integer qio = Workspace::get_IO();
1146
1147 // important special case: scalar X
1148 //
1149 if (get_rank() == 1 && (!!X) && X->is_scalar())
1150 {
1151 const APL_Integer idx = X->get_ravel(0).get_near_int() - qio;
1152 if (idx >= 0 && idx < max_idx)
1153 {
1154 Value_P Z(LOC);
1155 Z->next_ravel()->init(get_ravel(idx), Z.getref(), LOC);
1156 Z->check_value(LOC);
1157 return Z;
1158 }
1159 }
1160
1161 if (get_rank() != 1) RANK_ERROR;
1162
1163 if (!X) return clone(LOC); // elided index
1164
1165 const Shape shape_Z(X->get_shape());
1166 Value_P Z(shape_Z, LOC);
1167
1168 const Cell * cI = &X->get_ravel(0);
1169
1170 while (Z->more())
1171 {
1172 const ShapeItem idx = cI++->get_near_int() - qio;
1173 if (idx < 0 || idx >= max_idx)
1174 {
1175 MORE_ERROR() << "min index=⎕IO (=" << qio
1176 << "), offending index=" << (idx + qio)
1177 << ", max index=⎕IO+" << (max_idx - 1)
1178 << " (=" << (max_idx + qio - 1) << ")";
1179 Z->rollback(Z->valid_ravel_items, LOC);
1180 INDEX_ERROR;
1181 }
1182
1183 Z->next_ravel()->init(get_ravel(idx), Z.getref(), LOC);
1184 }
1185
1186 Z->set_default(*this, LOC);
1187 Z->check_value(LOC);
1188 return Z;
1189 }
1190 //-----------------------------------------------------------------------------
1191 Rank
get_single_axis(const Value * val,Rank max_axis)1192 Value::get_single_axis(const Value * val, Rank max_axis)
1193 {
1194 if (val == 0) AXIS_ERROR;
1195
1196 if (!val->is_scalar_or_len1_vector()) AXIS_ERROR;
1197
1198 if (!val->get_ravel(0).is_near_int()) AXIS_ERROR;
1199
1200 // if axis becomes (signed) negative then it will be (unsigned) too big.
1201 // Therefore we need not test for < 0.
1202 //
1203 const int axis = val->get_ravel(0).get_near_int() - Workspace::get_IO();
1204 if (axis >= max_axis) AXIS_ERROR;
1205
1206 return axis;
1207 }
1208 //-----------------------------------------------------------------------------
1209 Shape
to_shape(const Value * val)1210 Value::to_shape(const Value * val)
1211 {
1212 if (val == 0) INDEX_ERROR; // elided index ?
1213
1214 const ShapeItem xlen = val->element_count();
1215 const APL_Integer qio = Workspace::get_IO();
1216
1217 Shape shape;
1218 loop(x, xlen)
1219 shape.add_shape_item(val->get_ravel(x).get_near_int() - qio);
1220
1221 return shape;
1222 }
1223 //-----------------------------------------------------------------------------
1224 void
glue(Token & result,Token & token_A,Token & token_B,const char * loc)1225 Value::glue(Token & result, Token & token_A, Token & token_B, const char * loc)
1226 {
1227 Value_P A = token_A.get_apl_val();
1228 Value_P B = token_B.get_apl_val();
1229
1230 const bool strand_A = token_A.get_tag() == TOK_APL_VALUE3;
1231 const bool strand_B = token_B.get_tag() == TOK_APL_VALUE3;
1232
1233 if (strand_A)
1234 {
1235 if (strand_B) glue_strand_strand(result, A, B, loc);
1236 else glue_strand_closed(result, A, B, loc);
1237 }
1238 else
1239 {
1240 if (strand_B) glue_closed_strand(result, A, B, loc);
1241 else glue_closed_closed(result, A, B, loc);
1242 }
1243 }
1244 //-----------------------------------------------------------------------------
1245 void
glue_strand_strand(Token & result,Value_P A,Value_P B,const char * loc)1246 Value::glue_strand_strand(Token & result, Value_P A, Value_P B,
1247 const char * loc)
1248 {
1249 // glue two strands A and B
1250 //
1251 const ShapeItem len_A = A->element_count();
1252 const ShapeItem len_B = B->element_count();
1253
1254 Log(LOG_glue)
1255 {
1256 CERR << "gluing strands " << endl << *A
1257 << "with shape " << A->get_shape() << endl
1258 << " and " << endl << *B << endl
1259 << "with shape " << B->get_shape() << endl;
1260 }
1261
1262 Assert(A->is_scalar_or_vector());
1263 Assert(B->is_scalar_or_vector());
1264
1265 Value_P Z(len_A + len_B, LOC);
1266
1267 loop(a, len_A) Z->next_ravel()->init(A->get_ravel(a), Z.getref(), LOC);
1268 loop(b, len_B) Z->next_ravel()->init(B->get_ravel(b), Z.getref(), LOC);
1269
1270 Z->check_value(LOC);
1271 new (&result) Token(TOK_APL_VALUE3, Z);
1272 }
1273 //-----------------------------------------------------------------------------
1274 void
glue_strand_closed(Token & result,Value_P A,Value_P B,const char * loc)1275 Value::glue_strand_closed(Token & result, Value_P A, Value_P B,
1276 const char * loc)
1277 {
1278 // glue a strand A to new item B
1279 //
1280 Log(LOG_glue)
1281 {
1282 CERR << "gluing strand " << endl << *A
1283 << " to non-strand " << endl << *B << endl;
1284 }
1285
1286 Assert(A->is_scalar_or_vector());
1287
1288 const ShapeItem len_A = A->element_count();
1289 Value_P Z(len_A + 1, LOC);
1290
1291 loop(a, len_A) Z->next_ravel()->init(A->get_ravel(a), Z.getref(), LOC);
1292
1293 if (B->is_simple_scalar())
1294 {
1295 Z->next_ravel()->init(B->get_ravel(0), Z.getref(), LOC);
1296 }
1297 else
1298 {
1299 new (Z->next_ravel()) PointerCell(B.get(), Z.getref());
1300 }
1301
1302 Z->check_value(LOC);
1303 new (&result) Token(TOK_APL_VALUE3, Z);
1304 }
1305 //-----------------------------------------------------------------------------
1306 void
glue_closed_strand(Token & result,Value_P A,Value_P B,const char * loc)1307 Value::glue_closed_strand(Token & result, Value_P A, Value_P B,
1308 const char * loc)
1309 {
1310 // glue a new item A to the strand B
1311 //
1312 Log(LOG_glue)
1313 {
1314 CERR << "gluing non-strand " << endl << *A
1315 << " to strand " << endl << *B << endl;
1316 }
1317
1318 Assert(B->is_scalar_or_vector());
1319
1320 const ShapeItem len_B = B->element_count();
1321 Value_P Z(len_B + 1, LOC);
1322
1323 if (A->is_simple_scalar())
1324 {
1325 Z->next_ravel()->init(A->get_ravel(0), Z.getref(), LOC);
1326 }
1327 else
1328 {
1329 new (Z->next_ravel()) PointerCell(A.get(), Z.getref());
1330 }
1331
1332 loop(b, len_B) Z->next_ravel()->init(B->get_ravel(b), Z.getref(), LOC);
1333
1334 Z->check_value(LOC);
1335 new (&result) Token(TOK_APL_VALUE3, Z);
1336 }
1337 //-----------------------------------------------------------------------------
1338 void
glue_closed_closed(Token & result,Value_P A,Value_P B,const char * loc)1339 Value::glue_closed_closed(Token & result, Value_P A, Value_P B,
1340 const char * loc)
1341 {
1342 // glue two non-strands together, starting a strand
1343 //
1344 Log(LOG_glue)
1345 {
1346 CERR << "gluing two non-strands " << endl << *A
1347 << " and " << endl << *B << endl;
1348 }
1349
1350 Value_P Z(2, LOC);
1351 if (A->is_simple_scalar())
1352 {
1353 Z->next_ravel()->init(A->get_ravel(0), Z.getref(), LOC);
1354 }
1355 else
1356 {
1357 new (Z->next_ravel()) PointerCell(A.get(), Z.getref());
1358 }
1359
1360 if (B->is_simple_scalar())
1361 {
1362 Z->next_ravel()->init(B->get_ravel(0), Z.getref(), LOC);
1363 }
1364 else
1365 {
1366 new (Z->next_ravel()) PointerCell(B.get(), Z.getref());
1367 }
1368
1369 Z->check_value(LOC);
1370 new (&result) Token(TOK_APL_VALUE3, Z);
1371 }
1372 //-----------------------------------------------------------------------------
1373 void
check_value(const char * loc)1374 Value::check_value(const char * loc)
1375 {
1376 #ifdef VALUE_CHECK_WANTED
1377
1378 // if value was initialized by means of the next_ravel() mechanism,
1379 // then all cells are supposed to be OK.
1380 //
1381 if (valid_ravel_items && valid_ravel_items >= element_count())
1382 {
1383 set_complete();
1384 return;
1385 }
1386
1387 uint32_t error_count = 0;
1388 const Cell * C = &get_ravel(0);
1389
1390 const ShapeItem ec = nz_element_count();
1391 loop(c, ec)
1392 {
1393 const CellType ctype = C->get_cell_type();
1394 switch(ctype)
1395 {
1396 case CT_CHAR:
1397 case CT_POINTER:
1398 case CT_CELLREF:
1399 case CT_INT:
1400 case CT_FLOAT:
1401 case CT_COMPLEX: break; // OK
1402
1403 default:
1404 CERR << endl
1405 << "*** check_value(" << loc << ") detects:" << endl
1406 << " bad ravel[" << c << "] (CellType "
1407 << ctype << ")" << endl;
1408
1409 ++error_count;
1410 }
1411
1412 if (error_count >= 10)
1413 {
1414 CERR << endl << "..." << endl;
1415 break;
1416 }
1417
1418 ++C;
1419 }
1420
1421 if (error_count)
1422 {
1423 CERR << "Shape: " << get_shape() << endl;
1424 print(CERR) << endl
1425 << "************************************************"
1426 << endl;
1427 Assert(0 && "corrupt ravel");
1428 }
1429 #endif
1430
1431 set_complete();
1432 }
1433 //-----------------------------------------------------------------------------
1434 int
total_size_netto(CDR_type cdr_type) const1435 Value::total_size_netto(CDR_type cdr_type) const
1436 {
1437 if (cdr_type != 7) // not nested
1438 return 16 + 4*get_rank() + data_size(cdr_type);
1439
1440 // nested: header + offset-array + sub-values.
1441 //
1442 const ShapeItem ec = nz_element_count();
1443 int size = 16 + 4*get_rank() + 4*ec; // top_level size
1444 size = (size + 15) & ~15; // rounded up to 16 bytes
1445
1446 loop(e, ec)
1447 {
1448 const Cell & cell = get_ravel(e);
1449 if (cell.is_simple_cell())
1450 {
1451 // a non-pointer sub value consisting of its own 16 byte header,
1452 // and 1-16 data bytes, padded up to 16 bytes,
1453 //
1454 size += 32;
1455 }
1456 else if (cell.is_pointer_cell())
1457 {
1458 Value_P sub_val = cell.get_pointer_value();
1459 const CDR_type sub_type = sub_val->get_CDR_type();
1460 size += sub_val->total_size_brutto(sub_type);
1461 }
1462 else
1463 DOMAIN_ERROR;
1464 }
1465
1466 return size;
1467 }
1468 //-----------------------------------------------------------------------------
1469 int
data_size(CDR_type cdr_type) const1470 Value::data_size(CDR_type cdr_type) const
1471 {
1472 const ShapeItem ec = nz_element_count();
1473
1474 switch (cdr_type)
1475 {
1476 case 0: return (ec + 7) / 8; // 1/8 byte bit, rounded up
1477 case 1: return 4*ec; // 4 byte integer
1478 case 2: return 8*ec; // 8 byte float
1479 case 3: return 16*ec; // two 8 byte floats
1480 case 4: return ec; // 1 byte char
1481 case 5: return 4*ec; // 4 byte Unicode char
1482 case 7: break; // nested: continue below.
1483
1484 default: FIXME;
1485 }
1486
1487 // compute size of a nested CDR.
1488 // The top level consists of structural offsets that do not count as data.
1489 // We therefore simly add up the data sizes for the sub-values.
1490 //
1491 int size = 0;
1492 loop(e, ec)
1493 {
1494 const Cell & cell = get_ravel(e);
1495 if (cell.is_simple_cell())
1496 {
1497 size += cell.CDR_size();
1498 }
1499 else if (cell.is_pointer_cell())
1500 {
1501 Value_P sub_val = cell.get_pointer_value();
1502 const CDR_type sub_type = sub_val->get_CDR_type();
1503 size += sub_val->data_size(sub_type);
1504 }
1505 else
1506 DOMAIN_ERROR;
1507 }
1508
1509 return size;
1510 }
1511 //-----------------------------------------------------------------------------
1512 CDR_type
get_CDR_type() const1513 Value::get_CDR_type() const
1514 {
1515 const ShapeItem ec = nz_element_count();
1516 const Cell & cell_0 = get_ravel(0);
1517
1518 // if all cells are characters (8 or 32 bit), then return 4 or 5.
1519 // if all cells are numeric (1, 32, 64, or 128 bit, then return 0 ... 3
1520 // otherwise return 7 (nested)
1521
1522 if (cell_0.is_character_cell()) // 8 or 32 bit characters.
1523 {
1524 bool has_big = false; // assume 8-bit char
1525 loop(e, ec)
1526 {
1527 const Cell & cell = get_ravel(e);
1528 if (!cell.is_character_cell()) return CDR_NEST32;
1529 const Unicode uni = cell.get_char_value();
1530 if (uni < 0) has_big = true;
1531 if (uni >= 256) has_big = true;
1532 }
1533
1534 return has_big ? CDR_CHAR32 : CDR_CHAR8; // 8-bit or 32-bit char
1535 }
1536
1537 if (cell_0.is_numeric())
1538 {
1539 bool has_int = false;
1540 bool has_float = false;
1541 bool has_complex = false;
1542
1543 loop(e, ec)
1544 {
1545 const Cell & cell = get_ravel(e);
1546 if (cell.is_integer_cell())
1547 {
1548 const APL_Integer i = cell.get_int_value();
1549 if (i == 0) ;
1550 else if (i == 1) ;
1551 else if (i > 0x7FFFFFFFLL) has_float = true;
1552 else if (i < -0x80000000LL) has_float = true;
1553 else has_int = true;
1554 }
1555 else if (cell.is_float_cell())
1556 {
1557 has_float = true;
1558 }
1559 else if (cell.is_complex_cell())
1560 {
1561 has_complex = true;
1562 }
1563 else return CDR_NEST32; // mixed: return 7
1564 }
1565
1566 if (has_complex) return CDR_CPLX128;
1567 if (has_float) return CDR_FLT64;
1568 if (has_int) return CDR_INT32;
1569 return CDR_BOOL1;
1570 }
1571
1572 return CDR_NEST32;
1573 }
1574 //-----------------------------------------------------------------------------
1575 ostream &
print(ostream & out) const1576 Value::print(ostream & out) const
1577 {
1578 PrintContext pctx = Workspace::get_PrintContext(PR_APL);
1579 if (get_rank() == 0) // scalar
1580 {
1581 pctx.set_style(PR_APL_MIN);
1582 }
1583 else if (get_rank() == 1) // vector
1584 {
1585 if (element_count() == 0 && // empty vector
1586 (get_ravel(0).is_simple_cell()))
1587 {
1588 return out << endl;
1589 }
1590
1591 pctx.set_style(PR_APL_MIN);
1592 }
1593 else // matrix or higher
1594 {
1595 pctx.set_style(PrintStyle(pctx.get_style() | PST_NO_FRACT_0));
1596 }
1597
1598 PrintBuffer pb(*this, pctx, &out); // constructor prints it
1599 return out;
1600 }
1601 //-----------------------------------------------------------------------------
1602 ostream &
print1(ostream & out,PrintContext pctx) const1603 Value::print1(ostream & out, PrintContext pctx) const
1604 {
1605 int style = pctx.get_style();
1606 if (get_rank() < 2) // scalar or vector
1607 {
1608 style = PR_APL_MIN;
1609 }
1610 else // matrix or higher
1611 {
1612 style |= PST_NO_FRACT_0;
1613 }
1614
1615 pctx.set_style(PrintStyle(style));
1616
1617 PrintBuffer pb(*this, pctx, &out);
1618 return out;
1619 }
1620 //-----------------------------------------------------------------------------
1621 ostream &
print_properties(ostream & out,int indent,bool help) const1622 Value::print_properties(ostream & out, int indent, bool help) const
1623 {
1624 UCS_string ind(indent, UNI_ASCII_SPACE);
1625 if (help)
1626 {
1627 out << ind << "Rank: " << get_rank() << endl
1628 << ind << "Shape:";
1629 loop(r, get_rank()) out << " " << get_shape_item(r);
1630 out << endl
1631 << ind << "Depth: " << compute_depth() << endl
1632 << ind << "Type: ";
1633
1634 const CellType types = deep_cell_types();
1635 if (!(types & CT_CHAR)) // no chars in this value
1636 out << "numeric";
1637 else if (!(types & CT_NUMERIC)) // no numbers in this value
1638 out << "character";
1639 else // chars and numbers in this value
1640 out << "mixed";
1641 }
1642 else
1643 {
1644 out << ind << "Addr: " << voidP(this) << endl
1645 << ind << "Rank: " << get_rank() << endl
1646 << ind << "Shape: " << get_shape() << endl
1647 << ind << "Flags: " << get_flags();
1648 if (is_complete()) out << " VF_complete";
1649 if (is_marked()) out << " VF_marked";
1650 out << endl
1651 << ind << "First: " << get_ravel(0) << endl
1652 << ind << "Dynamic: ";
1653
1654 DynamicObject::print(out);
1655 }
1656 return out;
1657 }
1658 //-----------------------------------------------------------------------------
1659 void
debug(const char * info) const1660 Value::debug(const char * info) const
1661 {
1662 const PrintContext pctx = Workspace::get_PrintContext(PR_APL);
1663 PrintBuffer pb(*this, pctx, 0);
1664 pb.debug(CERR, info);
1665 }
1666 //-----------------------------------------------------------------------------
1667 ostream &
print_boxed(ostream & out,const char * info) const1668 Value::print_boxed(ostream & out, const char * info) const
1669 {
1670 if (info) out << info << endl;
1671
1672 const PrintContext pctx(PST_NONE);
1673
1674 Value_P Z = Quad_CR::do_CR(4, this, pctx);
1675 out << *Z << endl;
1676 return out;
1677 }
1678 //-----------------------------------------------------------------------------
1679 UCS_string
get_UCS_ravel() const1680 Value::get_UCS_ravel() const
1681 {
1682 UCS_string ucs;
1683
1684 const ShapeItem ec = element_count();
1685 loop(e, ec) ucs.append(get_ravel(e).get_char_value());
1686
1687 return ucs;
1688 }
1689 //-----------------------------------------------------------------------------
1690 void
to_proto()1691 Value::to_proto()
1692 {
1693 const ShapeItem ec = nz_element_count();
1694 Cell * c = &get_ravel(0);
1695
1696 loop(e, ec)
1697 {
1698 if (c->is_pointer_cell()) c->get_pointer_value()->to_proto();
1699 else if (c->is_character_cell()) new (c) CharCell(UNI_ASCII_SPACE);
1700 else new (c) IntCell(0);
1701 ++c;
1702 }
1703 }
1704 //-----------------------------------------------------------------------------
1705 void
print_structure(ostream & out,int indent,ShapeItem idx) const1706 Value::print_structure(ostream & out, int indent, ShapeItem idx) const
1707 {
1708 loop(i, indent) out << " ";
1709 if (indent) out << "[" << idx << "] ";
1710 out << "addr=" << voidP(this)
1711 << " ≡" << compute_depth()
1712 << " ⍴" << get_shape()
1713 << " flags: " << HEX4(get_flags()) << " "
1714 << get_flags()
1715 << " " << where_allocated()
1716 << endl;
1717
1718 const ShapeItem ec = nz_element_count();
1719 const Cell * c = &get_ravel(0);
1720 loop(e, ec)
1721 {
1722 if (c->is_pointer_cell())
1723 c->get_pointer_value()->print_structure(out, indent + 1, e);
1724 ++c;
1725 }
1726 }
1727 //-----------------------------------------------------------------------------
1728 Value_P
clone(const char * loc) const1729 Value::clone(const char * loc) const
1730 {
1731 #ifdef PERFORMANCE_COUNTERS_WANTED
1732 const uint64_t start_1 = cycle_counter();
1733 #endif
1734
1735 Value_P Z(get_shape(), loc);
1736
1737 const Cell * src = &get_ravel(0);
1738 Cell * dst = &Z->get_ravel(0);
1739 const ShapeItem count = nz_element_count();
1740
1741 loop(c, count) src++->init_other(dst++, Z.getref(), LOC);
1742
1743 Z->check_value(LOC);
1744
1745 #ifdef PERFORMANCE_COUNTERS_WANTED
1746 const uint64_t end_1 = cycle_counter();
1747 Performance::fs_clone_B.add_sample(end_1 - start_1, count);
1748 #endif
1749
1750 return Z;
1751 }
1752 //-----------------------------------------------------------------------------
1753 Value_P
prototype(const char * loc) const1754 Value::prototype(const char * loc) const
1755 {
1756 // the type of an array is an array with the same structure, but all numbers
1757 // replaced with 0 and all chars replaced with ' '.
1758 //
1759 // the prototype of an array is the type of the first element of the array.
1760
1761 const Cell & first = get_ravel(0);
1762 if (first.is_integer_cell()) return IntScalar(0, LOC);
1763 if (first.is_character_cell()) return CharScalar(UNI_ASCII_SPACE, LOC);
1764 if (first.is_pointer_cell())
1765 {
1766 Value_P B0 = first.get_pointer_value();
1767 Value_P Z(B0->get_shape(), loc);
1768 const ShapeItem ec_Z = Z->element_count();
1769
1770 loop(z, ec_Z)
1771 Z->next_ravel()->init_type(B0->get_ravel(z), Z.getref(), LOC);
1772 Z->set_complete();
1773 return Z;
1774 }
1775
1776 DOMAIN_ERROR;
1777 }
1778 //-----------------------------------------------------------------------------
1779 /// lrp p.138: S←⍴⍴A + NOTCHAR (per column)
1780 int32_t
get_col_spacing(bool & not_char,ShapeItem col,bool framed) const1781 Value::get_col_spacing(bool & not_char, ShapeItem col, bool framed) const
1782 {
1783 int32_t max_spacing = 0;
1784 not_char = false;
1785
1786 const ShapeItem ec = element_count();
1787 const ShapeItem cols = get_last_shape_item();
1788 const ShapeItem rows = ec/cols;
1789 loop(row, rows)
1790 {
1791 // compute spacing, which is the spacing required by this item.
1792 //
1793 int32_t spacing = 1; // assume simple numeric
1794 const Cell & cell = get_ravel(col + row*cols);
1795
1796 if (cell.is_pointer_cell()) // nested
1797 {
1798 if (framed)
1799 {
1800 not_char = true;
1801 spacing = 1;
1802 }
1803 else
1804 {
1805 Value_P v = cell.get_pointer_value();
1806 spacing = v->get_rank();
1807 if (v->NOTCHAR())
1808 {
1809 not_char = true;
1810 ++spacing;
1811 }
1812 }
1813 }
1814 else if (cell.is_character_cell()) // simple char
1815 {
1816 spacing = 0;
1817 }
1818 else // simple numeric
1819 {
1820 not_char = true;
1821 }
1822
1823 if (max_spacing < spacing) max_spacing = spacing;
1824 }
1825
1826 return max_spacing;
1827 }
1828 //-----------------------------------------------------------------------------
1829 int
print_incomplete(ostream & out)1830 Value::print_incomplete(ostream & out)
1831 {
1832 std::vector<const Value *> incomplete;
1833 bool goon = true;
1834
1835 for (const DynamicObject * dob = all_values.get_prev();
1836 goon && (dob != &all_values); dob = dob->get_prev())
1837 {
1838 const Value * val = dob->pValue();
1839 goon = (dob != dob->get_prev());
1840
1841 if (val->is_complete()) continue;
1842
1843 out << "incomplete value at " << voidP(val) << endl;
1844 incomplete.push_back(val);
1845
1846 if (!goon)
1847 {
1848 out << "Value::print_incomplete() : endless loop in "
1849 "Value::all_values; stopping display." << endl;
1850 }
1851 }
1852
1853 // then print more info...
1854 //
1855 loop(s, incomplete.size())
1856 {
1857 incomplete[s]->print_stale_info(out, incomplete[s]);
1858 }
1859
1860 return incomplete.size();
1861 }
1862 //-----------------------------------------------------------------------------
1863 int
print_stale(ostream & out)1864 Value::print_stale(ostream & out)
1865 {
1866 std::vector<const Value *> stale_vals;
1867 std::vector<const DynamicObject *> stale_dobs;
1868 bool goon = true;
1869 int count = 0;
1870
1871 // first print addresses and remember stale values
1872 //
1873 for (const DynamicObject * dob = all_values.get_prev();
1874 goon && (dob != &all_values); dob = dob->get_prev())
1875 {
1876 const Value * val = dob->pValue();
1877 goon = (dob == dob->get_prev());
1878
1879 if (val->owner_count) continue;
1880
1881 out << "stale value at " << voidP(val) << endl;
1882 stale_vals.push_back(val);
1883 stale_dobs.push_back(dob);
1884
1885 if (!goon)
1886 {
1887 out << "Value::print_stale() : endless loop in "
1888 "Value::all_values; stopping display." << endl;
1889 }
1890 }
1891
1892 // then print more info...
1893 //
1894 loop(s, stale_vals.size())
1895 {
1896 const DynamicObject * dob = stale_dobs[s];
1897 const Value * val = stale_vals[s];
1898 val->print_stale_info(out, dob);
1899 ++count;
1900 }
1901
1902 // mark all dynamic values, and then unmark those known in the workspace
1903 //
1904 mark_all_dynamic_values();
1905 Workspace::unmark_all_values();
1906 Macro::unmark_all_macros();
1907
1908 // print all values that are still marked
1909 //
1910 for (const DynamicObject * dob = all_values.get_prev();
1911 dob != &all_values; dob = dob->get_prev())
1912 {
1913 const Value * val = dob->pValue();
1914
1915 // don't print values found in the previous round.
1916 //
1917 bool known_stale = false;
1918 loop(s, stale_vals.size())
1919 {
1920 if (val == stale_vals[s])
1921 {
1922 known_stale = true;
1923 break;
1924 }
1925 }
1926 if (known_stale) continue;
1927
1928 if (val->is_marked())
1929 {
1930 val->print_stale_info(out, dob);
1931 ++count;
1932 val->unmark();
1933 }
1934 }
1935
1936 return count;
1937 }
1938 //-----------------------------------------------------------------------------
1939 void
print_stale_info(ostream & out,const DynamicObject * dob) const1940 Value::print_stale_info(ostream & out, const DynamicObject * dob) const
1941 {
1942 out << "print_stale_info(): alloc(" << dob->where_allocated()
1943 << ") flags(" << get_flags() << ")" << endl;
1944
1945 VH_entry::print_history(out, dob->pValue(), LOC);
1946
1947 try
1948 {
1949 print_structure(out, 0, 0);
1950 const PrintContext pctx(PST_NONE);
1951 Value_P Z = Quad_CR::do_CR(7, this, pctx);
1952 Z->print(out);
1953 out << endl;
1954 }
1955 catch (...) { out << " *** corrupt ***"; }
1956
1957 out << endl;
1958 }
1959 //-----------------------------------------------------------------------------
1960 ostream &
operator <<(ostream & out,const Value & v)1961 operator<<(ostream & out, const Value & v)
1962 {
1963 v.print(out);
1964 return out;
1965 }
1966 //-----------------------------------------------------------------------------
1967 Value_P
IntScalar(APL_Integer val,const char * loc)1968 IntScalar(APL_Integer val, const char * loc)
1969 {
1970 Value_P Z(loc);
1971 new (Z->next_ravel()) IntCell(val);
1972 Z->check_value(LOC);
1973 return Z;
1974 }
1975 //-----------------------------------------------------------------------------
1976 Value_P
FloatScalar(APL_Float val,const char * loc)1977 FloatScalar(APL_Float val, const char * loc)
1978 {
1979 Value_P Z(loc);
1980 new (Z->next_ravel()) FloatCell(val);
1981 Z->check_value(LOC);
1982 return Z;
1983 }
1984 //-----------------------------------------------------------------------------
1985 Value_P
ComplexScalar(APL_Complex val,const char * loc)1986 ComplexScalar(APL_Complex val, const char * loc)
1987 {
1988 Value_P Z(loc);
1989 new (Z->next_ravel()) ComplexCell(val);
1990 Z->check_value(LOC);
1991 return Z;
1992 }
1993 //-----------------------------------------------------------------------------
1994 Value_P
CharScalar(Unicode uni,const char * loc)1995 CharScalar(Unicode uni, const char * loc)
1996 {
1997 Value_P Z(loc);
1998 new (Z->next_ravel()) CharCell(uni);
1999 Z->check_value(LOC);
2000 return Z;
2001 }
2002 //-----------------------------------------------------------------------------
2003 Value_P
Idx0(const char * loc)2004 Idx0(const char * loc)
2005 {
2006 Value_P Z(ShapeItem(0), loc);
2007 Z->check_value(LOC);
2008 return Z;
2009 }
2010 //-----------------------------------------------------------------------------
2011 Value_P
Str0(const char * loc)2012 Str0(const char * loc)
2013 {
2014 Value_P Z(ShapeItem(0), loc);
2015 Z->set_proto_Spc();
2016 Z->check_value(LOC);
2017 return Z;
2018 }
2019 //-----------------------------------------------------------------------------
2020 Value_P
Str0_0(const char * loc)2021 Str0_0(const char * loc)
2022 {
2023 Shape sh(ShapeItem(0), ShapeItem(0));
2024 Value_P Z(sh, loc);
2025 Z->set_proto_Spc();
2026 Z->check_value(LOC);
2027 return Z;
2028 }
2029 //-----------------------------------------------------------------------------
2030 Value_P
Idx0_0(const char * loc)2031 Idx0_0(const char * loc)
2032 {
2033 Shape sh(ShapeItem(0), ShapeItem(0));
2034 Value_P Z(sh, loc);
2035 Z->check_value(LOC);
2036 return Z;
2037 }
2038 //-----------------------------------------------------------------------------
operator <<(ostream & out,const AP_num3 & ap3)2039 ostream & operator << (ostream & out, const AP_num3 & ap3)
2040 {
2041 return out << ap3.proc << "." << ap3.parent << "." << ap3.grand;
2042 }
2043 //-----------------------------------------------------------------------------
2044
2045