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-2016 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 <dirent.h>
22 #include <errno.h>
23 #include <limits.h>
24 #include <string.h>
25 #include <sys/resource.h>
26
27 #include "CharCell.hh"
28 #include "ComplexCell.hh"
29 #include "Command.hh"
30 #include "Doxy.hh"
31 #include "Executable.hh"
32 #include "FloatCell.hh"
33 #include "IndexExpr.hh"
34 #include "IntCell.hh"
35 #include "IO_Files.hh"
36 #include "LineInput.hh"
37 #include "Nabla.hh"
38 #include "NativeFunction.hh"
39 #include "Output.hh"
40 #include "Parser.hh"
41 #include "Prefix.hh"
42 #include "Quad_FX.hh"
43 #include "Quad_TF.hh"
44 #include "StateIndicator.hh"
45 #include "Svar_DB.hh"
46 #include "Symbol.hh"
47 #include "Tokenizer.hh"
48 #include "UserFunction.hh"
49 #include "UserPreferences.hh"
50 #include "ValueHistory.hh"
51 #include "Workspace.hh"
52
53 #include "Value.hh"
54
55 int Command::boxing_format = 0;
56 ShapeItem Command::APL_expression_count = 0;
57
58 //-----------------------------------------------------------------------------
59 void
process_line()60 Command::process_line()
61 {
62 UCS_string accu; // for new-style multiline strings
63 UCS_string prompt = Workspace::get_prompt();
64 for (;;)
65 {
66 UCS_string line;
67 bool eof = false;
68 InputMux::get_line(LIM_ImmediateExecution, prompt,
69 line, eof, LineInput::get_history());
70
71 if (eof) CERR << "EOF at " << LOC << endl;
72
73 if (line.ends_with("\"\"\"")) /// start or end of multi-line
74 {
75 if (accu.size() == 0) // start of multi-line
76 {
77 accu = line;
78 prompt.prepend(UNI_RIGHT_ARROW);
79 accu.resize(line.size() - 3); // discard """
80 accu.append(UNI_ASCII_SPACE);
81 }
82 else // end of multi-line
83 {
84 accu.pop_back(); // trailing " "
85 process_line(accu);
86 return;
87 }
88 }
89 else if (accu.size()) // inside multi-line
90 {
91 accu.append_ASCII("\"");
92 accu.append(line.do_escape(true));
93 accu.append_ASCII("\" ");
94 }
95 else // normal input line
96 {
97 process_line(line);
98 return;
99 }
100 }
101 }
102 //-----------------------------------------------------------------------------
103 void
process_line(UCS_string & line)104 Command::process_line(UCS_string & line)
105 {
106 line.remove_leading_whitespaces();
107 if (line.size() == 0) return; // empty input line
108
109 switch(line[0])
110 {
111 case UNI_ASCII_R_PARENT: // regular command, e.g. )SI
112 do_APL_command(COUT, line);
113 if (line.size()) break;
114 return;
115
116 case UNI_ASCII_R_BRACK: // debug command, e.g. ]LOG
117 do_APL_command(CERR, line);
118 if (line.size()) break;
119 return;
120
121 case UNI_NABLA: // e.g. ∇FUN
122 Nabla::edit_function(line);
123 return;
124
125 case UNI_ASCII_NUMBER_SIGN: // e.g. # comment
126 case UNI_COMMENT: // e.g. ⍝ comment
127 return;
128
129 default: ;
130 }
131
132 ++APL_expression_count;
133 do_APL_expression(line);
134 }
135 //-----------------------------------------------------------------------------
136 bool
do_APL_command(ostream & out,UCS_string & line)137 Command::do_APL_command(ostream & out, UCS_string & line)
138 {
139 const UCS_string line1(line); // the original line
140
141 // split line into command and arguments
142 //
143 UCS_string cmd; // the command without arguments
144 int len = 0;
145 line.copy_black(cmd, len);
146
147 UCS_string arg(line, len, line.size() - len);
148 UCS_string_vector args = split_arg(arg);
149 line.clear();
150 if (!cmd.starts_iwith(")MORE"))
151 {
152 // clear )MORE info unless command is )MORE
153 //
154 Workspace::more_error().clear();
155 }
156
157 #define cmd_def(cmd_str, code, garg, _hint) \
158 if (cmd.starts_iwith(cmd_str)) \
159 { if (check_params(out, cmd_str, args.size(), garg)) return true; \
160 code; return false; }
161 #include "Command.def"
162
163 // check for user defined commands...
164 //
165 loop(u, Workspace::get_user_commands().size())
166 {
167 if (cmd.starts_iwith(Workspace::get_user_commands()[u].prefix))
168 {
169 do_USERCMD(out, line, line1, cmd, args, u);
170 return true;
171 }
172 }
173
174 out << "BAD COMMAND" << endl;
175 return false;
176 }
177 //-----------------------------------------------------------------------------
178 bool
check_params(ostream & out,const char * command,int argc,const char * args)179 Command::check_params(ostream & out, const char * command, int argc,
180 const char * args)
181 {
182 // allow everything for ]USERCMD
183 //
184 if (!strcmp(command, "]USERCMD")) return false;
185
186 // analyze args to figure the number of parametes expected.
187 //
188 int mandatory_args = 0;
189 int opt_args = 0;
190 int brackets = 0;
191 bool in_param = false;
192 bool many = false;
193
194 UCS_string args_ucs(args);
195 loop (a, args_ucs.size()) switch(args_ucs[a])
196 {
197 case '[': ++brackets; in_param = false; continue;
198 case ']': --brackets; in_param = false; continue;
199 case '|': in_param = false;
200 if (brackets) --opt_args;
201 else --mandatory_args;
202 continue;
203 case '.':
204 if (a < (args_ucs.size() - 2) &&
205 args_ucs[a + 1] == '.' &&
206 args_ucs[a + 2] == '.') many = true;
207 continue;
208 case '0' ... '9':
209 case '_':
210 case 'A' ... 'Z':
211 case 'a' ... 'z':
212 case UNI_OVERBAR:
213 case '-':
214 if (!in_param) // start of a name or range
215 {
216 if (brackets) ++opt_args;
217 else ++mandatory_args;
218 in_param = true;
219 }
220 continue;
221
222 case ' ': in_param = false;
223 continue;
224
225 default: Q(args_ucs[a]) Q(int(args_ucs[a]))
226 }
227
228 if (argc < mandatory_args) // too few parameters
229 {
230 out << "BAD COMMAND+" << endl;
231 MORE_ERROR() << "missing parameter(s) in command " << command
232 << ". Usage:\n"
233 << " " << command << " " << args;
234 return true;
235 }
236
237 if (many) return false;
238
239 if (argc > (mandatory_args + opt_args)) // too many parameters
240 {
241 out << "BAD COMMAND+" << endl;
242 MORE_ERROR() << "too many (" << argc<< ") parameter(s) in command "
243 << command << ". Usage:\n"
244 << " " << command << " " << args;
245 return true;
246 }
247
248 return false; // OK
249 }
250 //-----------------------------------------------------------------------------
251 void
do_APL_expression(UCS_string & line)252 Command::do_APL_expression(UCS_string & line)
253 {
254 Workspace::more_error().clear();
255
256 Executable * statements = 0;
257 try
258 {
259 statements = StatementList::fix(line, LOC);
260 }
261 catch (Error err)
262 {
263 UERR << Error::error_name(err.get_error_code());
264 if (Workspace::more_error().size()) UERR << UNI_ASCII_PLUS;
265 UERR << endl;
266 if (*err.get_error_line_2())
267 {
268 COUT << " " << err.get_error_line_2() << endl
269 << " " << err.get_error_line_3() << endl;
270 }
271
272 err.print(UERR, LOC);
273 delete statements;
274 return;
275 }
276 catch (...)
277 {
278 CERR << "*** Command::process_line() caught other exception ***"
279 << endl;
280 delete statements;
281 cmd_OFF(0);
282 }
283
284 if (statements == 0)
285 {
286 COUT << "main: Parse error." << endl;
287 return;
288 }
289
290 // At this point, the user command was parsed correctly.
291 // check for Escape (→)
292 //
293 {
294 const Token_string & body = statements->get_body();
295 if (body.size() == 3 &&
296 body[0].get_tag() == TOK_ESCAPE &&
297 body[1].get_Class() == TC_END &&
298 body[2].get_tag() == TOK_RETURN_STATS)
299 {
300 // remove all SI entries up to (including) the next immediate
301 // execution context
302 //
303 for (bool goon = true; goon;)
304 {
305 StateIndicator * si = Workspace::SI_top();
306 if (si == 0) break; // SI empty
307
308 goon = si->get_parse_mode() != PM_STATEMENT_LIST;
309 si->escape(); // pop local vars of user defined functions
310 Workspace::pop_SI(LOC);
311 }
312
313 delete statements;
314 return;
315 }
316 }
317
318 // statements->print(CERR);
319
320 // push a new context for the statements.
321 //
322 Workspace::push_SI(statements, LOC);
323 finish_context();
324 }
325 //-----------------------------------------------------------------------------
326 void
finish_context()327 Command::finish_context()
328 {
329 for (;;)
330 {
331 //
332 // NOTE that the entire SI may change while executing this loop.
333 // We should therefore avoid references to SI entries.
334 //
335 Token token = Workspace::SI_top()->get_executable()->execute_body();
336
337 // Q(token)
338
339 // start over if execution has pushed a new SI entry
340 //
341 if (token.get_tag() == TOK_SI_PUSHED) continue;
342
343 check_EOC:
344 if (Workspace::SI_top()->is_safe_execution_start())
345 {
346 Quad_EC::eoc(token);
347 }
348
349 // the far most frequent cases are TC_VALUE and TOK_VOID
350 // so we handle them first.
351 //
352 if (token.get_Class() == TC_VALUE || token.get_tag() == TOK_VOID )
353 {
354 if (Workspace::SI_top()->get_parse_mode() == PM_STATEMENT_LIST)
355 {
356 if (attention_is_raised())
357 {
358 clear_attention_raised(LOC);
359 clear_interrupt_raised(LOC);
360 ATTENTION;
361 }
362
363 break; // will return to calling context
364 }
365
366 Workspace::pop_SI(LOC);
367
368 // we are back in the calling SI. There should be a TOK_SI_PUSHED
369 // token at the top of stack. Replace it with the result from
370 // the called (just poped) SI.
371 //
372 {
373 Prefix & prefix =
374 Workspace::SI_top()->get_prefix();
375 Assert(prefix.at0().get_tag() == TOK_SI_PUSHED);
376
377 new (&prefix.tos().tok) Token(token);
378 }
379 if (attention_is_raised())
380 {
381 clear_attention_raised(LOC);
382 clear_interrupt_raised(LOC);
383 ATTENTION;
384 }
385
386 continue;
387 }
388
389 if (token.get_tag() == TOK_BRANCH)
390 {
391 const Function_Line line = Function_Line(token.get_int_val());
392 if (line == Function_Retry &&
393 Workspace::SI_top()->get_parse_mode() == PM_STATEMENT_LIST &&
394 Workspace::SI_top()->get_parent())
395 {
396 Workspace::pop_SI(LOC);
397 Workspace::SI_top()->retry(LOC);
398 continue;
399 }
400
401 StateIndicator * si = Workspace::SI_top_fun();
402
403 if (si == 0)
404 {
405 MORE_ERROR() <<
406 "branch back into function (→N) without suspended function";
407 SYNTAX_ERROR; // →N without function,
408 }
409
410 // pop contexts above defined function
411 //
412 while (si != Workspace::SI_top()) Workspace::pop_SI(LOC);
413
414 si->goon(line, LOC);
415 continue;
416 }
417
418 if (token.get_tag() == TOK_ESCAPE)
419 {
420 // remove all SI entries up to (including) the next immediate
421 // execution context
422 //
423 for (bool goon = true; goon;)
424 {
425 StateIndicator * si = Workspace::SI_top();
426 if (si == 0) break; // SI empty
427
428 goon = si->get_parse_mode() != PM_STATEMENT_LIST;
429 si->escape(); // pop local vars of user defined functions
430 Workspace::pop_SI(LOC);
431 }
432 return;
433 }
434
435 if (token.get_tag() == TOK_ERROR)
436 {
437 if (token.get_int_val() == E_COMMAND_PUSHED)
438 {
439 Workspace::pop_SI(LOC);
440 UCS_string pushed_command = Workspace::get_pushed_Command();
441 process_line(pushed_command);
442 pushed_command.clear();
443 Workspace::push_Command(pushed_command); // clear in
444 return;
445 }
446
447 // clear attention and interrupt flags
448 //
449 clear_attention_raised(LOC);
450 clear_interrupt_raised(LOC);
451
452 // check for safe execution mode. Unroll all SI entries that
453 // have the same safe_execution_count, except the last
454 // unroll the SI stack.
455 //
456 if (Workspace::SI_top()->get_safe_execution())
457 {
458 StateIndicator * si = Workspace::SI_top();
459 while (si->get_parent() && si->get_safe_execution() ==
460 si->get_parent()->get_safe_execution())
461 {
462 si = si->get_parent();
463 Workspace::pop_SI(LOC);
464 }
465
466 goto check_EOC;
467 }
468
469 // if suspend is not allowed then pop all SI entries that
470 // don't allow suspend
471 //
472 if (Workspace::SI_top()->get_executable()->cannot_suspend())
473 {
474 Error err = StateIndicator::get_error(Workspace::SI_top());
475 while (Workspace::SI_top()->get_executable()
476 ->cannot_suspend())
477 {
478 Workspace::pop_SI(LOC);
479 }
480
481 if (Workspace::SI_top())
482 {
483 StateIndicator::get_error(Workspace::SI_top()) = err;
484 }
485 }
486
487 if (Workspace::get_error()->get_print_loc() == 0) // not printed
488 {
489 Workspace::get_error()->print(CERR, LOC);
490 }
491 else
492 {
493 // CERR << "ERROR printed twice" << endl;
494 }
495
496 if (Workspace::SI_top()->get_level() == 0)
497 {
498 Value::erase_stale(LOC);
499 IndexExpr::erase_stale(LOC);
500 }
501 return;
502 }
503
504 // we should not come here.
505 //
506 Q1(token) Q1(token.get_Class()) Q1(token.get_tag()) FIXME;
507 }
508
509 // pop the context for the statements
510 //
511 Workspace::pop_SI(LOC);
512 }
513 //-----------------------------------------------------------------------------
514 void
cmd_XTERM(ostream & out,const UCS_string & arg)515 Command::cmd_XTERM(ostream & out, const UCS_string & arg)
516 {
517 const char * term = getenv("TERM");
518 if (!strncmp(term, "dumb", 4) && arg.starts_iwith("ON"))
519 {
520 out << "impossible on dumb terminal" << endl;
521 }
522 else if (arg.starts_iwith("OFF") || arg.starts_iwith("ON"))
523 {
524 Output::toggle_color(arg);
525 }
526 else if (arg.size() == 0)
527 {
528 out << "]COLOR/XTERM ";
529 if (Output::color_enabled()) out << "ON"; else out << "OFF";
530 out << endl;
531 }
532 else
533 {
534 out << "BAD COMMAND" << endl;
535 return;
536 }
537 }
538 //-----------------------------------------------------------------------------
539 UCS_string_vector
split_arg(const UCS_string & arg)540 Command::split_arg(const UCS_string & arg)
541 {
542 UCS_string_vector result;
543 for (int idx = 0; ; )
544 {
545 UCS_string next;
546 arg.copy_black(next, idx);
547 if (next.size() == 0) return result;
548
549 result.push_back(next);
550 }
551 }
552 //-----------------------------------------------------------------------------
553 void
cmd_BOXING(ostream & out,const UCS_string & arg)554 Command::cmd_BOXING(ostream & out, const UCS_string & arg)
555 {
556 int format = arg.atoi();
557
558 if (arg.size() == 0)
559 {
560 out << "]BOXING ";
561 if (boxing_format == 0) out << "OFF";
562 else out << boxing_format;
563 out << endl;
564 return;
565 }
566
567 if (arg.starts_iwith("OFF")) format = 0;
568 switch (format)
569 {
570 case -29:
571 case -25: case -24: case -23:
572 case -22: case -21: case -20:
573 case -9: case -8: case -7:
574 case -4: case -3: case -2:
575 case 0:
576 case 2: case 3: case 4:
577 case 7: case 8: case 9:
578 case 20: case 21: case 22:
579 case 23: case 24: case 25:
580 case 29:
581 boxing_format = format;
582 return;
583 }
584
585 out << "BAD ]BOXING PARAMETER+" << endl;
586 MORE_ERROR() << "Parameter " << arg << " is not valid for command ]BOXING.\n"
587 " Valid parameters are OFF, N, and -N with\n"
588 " N ∈ { 2, 3, 4, 7, 8, 9, 20, 21, 22, 23, 24, 25, 29 }";
589 }
590 //-----------------------------------------------------------------------------
591 bool
compare_val_val(const val_val & A,const val_val & B,const void *)592 Command::val_val::compare_val_val(const val_val & A,
593 const val_val & B, const void *)
594 {
595 return A.child > B.child;
596 }
597 //-----------------------------------------------------------------------------
598 int
compare_val_val1(const void * key,const void * B)599 Command::val_val::compare_val_val1(const void * key, const void * B)
600 {
601 const void * Bv = reinterpret_cast<const val_val *>(B)->child;
602 return charP(key) - charP(Bv);
603 }
604 //-----------------------------------------------------------------------------
605 void
cmd_CHECK(ostream & out)606 Command::cmd_CHECK(ostream & out)
607 {
608 // erase stale functions from failed ⎕EX
609 //
610 {
611 bool erased = false;
612 int stale = Workspace::cleanup_expunged(CERR, erased);
613 if (stale)
614 {
615 out << "WARNING - " << stale << " stale functions ("
616 << (erased ? "" : "not ") << "erased)" << endl;
617 }
618 else out << "OK - no stale functions" << endl;
619 }
620
621 {
622 const int stale = Value::print_stale(CERR);
623 if (stale)
624 {
625 out << "ERROR - " << stale << " stale values" << endl;
626 IO_Files::apl_error(LOC);
627 }
628 else out << "OK - no stale values" << endl;
629 }
630 {
631 const int stale = IndexExpr::print_stale(CERR);
632 if (stale)
633 {
634 out << "ERROR - " << stale << " stale indices" << endl;
635 IO_Files::apl_error(LOC);
636 }
637 else out << "OK - no stale indices" << endl;
638 }
639
640 // discover duplicate parents
641 //
642 std::vector<val_val> values;
643 ShapeItem duplicate_parents = 0;
644 for (const DynamicObject * obj = DynamicObject::get_all_values()->get_next();
645 obj != DynamicObject::get_all_values(); obj = obj->get_next())
646 {
647 const Value * val = static_cast<const Value *>(obj);
648
649 val_val vv = { 0, val }; // no parent
650 values.push_back(vv);
651 }
652
653 Heapsort<val_val>::sort(&values[0], values.size(), 0,
654 &val_val::compare_val_val);
655 loop(v, (values.size() - 1))
656 Assert(&values[v].child < &values[v + 1].child);
657
658 /// set parents
659 loop(v, values.size()) // for every .child (acting as parent here)
660 {
661 const Value * val = values[v].child;
662 const ShapeItem ec = val->nz_element_count();
663 loop(e, ec) // for every ravel cell of the (parent-) value
664 {
665 const Cell & cP = val->get_ravel(e);
666 if (!cP.is_pointer_cell()) continue; // not a parent
667
668 const Value * sub = cP.get_pointer_value().get();
669 Assert1(sub);
670
671 val_val * vvp = reinterpret_cast<val_val *>
672 (bsearch(sub, &values[0], values.size(), sizeof(val_val),
673 val_val::compare_val_val1));
674 Assert(vvp);
675 if (vvp->parent == 0) // child has no parent
676 {
677 vvp->parent = val;
678 }
679 else
680 {
681 ++duplicate_parents;
682 out << "Value * vvp=" << voidP(vvp) << " already has parent "
683 << voidP(vvp->parent) << " when checking Value * val="
684 << voidP(vvp) << endl;
685
686 out << "History of the child:" << endl;
687 VH_entry::print_history(out, vvp->child, LOC);
688 out << "History of the first parent:" << endl;
689 VH_entry::print_history(out, vvp->parent, LOC);
690 out << "History of the second parent:" << endl;
691 VH_entry::print_history(out, val, LOC);
692 out << endl;
693 }
694 }
695 }
696
697 if (duplicate_parents)
698 {
699 out << "ERROR - " << duplicate_parents
700 << " duplicate parents" << endl;
701 IO_Files::apl_error(LOC);
702 }
703 else out << "OK - no duplicate parents" << endl;
704 }
705 //-----------------------------------------------------------------------------
706 void
cmd_CONTINUE(ostream & out)707 Command::cmd_CONTINUE(ostream & out)
708 {
709 UCS_string wsname("CONTINUE");
710 Workspace::wsid(out, wsname, LIB0, false); // )WSID CONTINUE
711 Workspace::save_WS(out, LIB0, wsname, true); // )SAVE
712 cmd_OFF(0); // )OFF
713 }
714 //-----------------------------------------------------------------------------
715 void
cmd_COPY(ostream & out,UCS_string_vector & args,bool protection)716 Command::cmd_COPY(ostream & out, UCS_string_vector & args, bool protection)
717 {
718 LibRef libref = LIB0;
719 const Unicode l = args[0][0];
720 if (Avec::is_digit(l))
721 {
722 libref = LibRef(l - '0');
723 args.erase(args.begin());
724 }
725
726 if (args.size() == 0) // at least workspace name is required
727 {
728 out << "BAD COMMAND+" << endl;
729 MORE_ERROR() << "missing workspace name in command )COPY or )PCOPY";
730 return;
731 }
732
733 UCS_string wsname = args[0];
734 args.erase(args.begin());
735 Workspace::copy_WS(out, libref, wsname, args, protection);
736 }
737 //-----------------------------------------------------------------------------
738 void
cmd_DOXY(ostream & out,UCS_string_vector & args)739 Command::cmd_DOXY(ostream & out, UCS_string_vector & args)
740 {
741 UTF8_string root("/tmp");
742 if (args.size()) root = UTF8_string(args[0]);
743
744 try
745 {
746 Doxy doxy(out, root);
747 doxy.gen();
748
749 if (doxy.get_errors())
750 out << "Command ]DOXY failed (" << doxy.get_errors() << " errors)"
751 << endl;
752 else
753 out << "Command ]DOXY finished successfully." << endl
754 << " The generated documentation was stored in directory "
755 << doxy.get_root_dir() << endl
756 << " You may want to browse it from file://"
757 << doxy.get_root_dir()
758 << "/index.html" << endl;
759 }
760 catch (...) {}
761 }
762 //-----------------------------------------------------------------------------
763 void
cmd_DROP(ostream & out,const UCS_string_vector & lib_ws)764 Command::cmd_DROP(ostream & out, const UCS_string_vector & lib_ws)
765 {
766 // Command is:
767 //
768 // )DROP wsname
769 // )DROP libnum wsname
770
771 // lib_ws.size() is 1 or 2. If 2 then the first is the lib number
772 //
773 LibRef libref = LIB_NONE;
774 UCS_string wname = lib_ws.back();
775 if (lib_ws.size() == 2) libref = LibRef(lib_ws[0][0] - '0');
776
777 UTF8_string filename = LibPaths::get_lib_filename(libref, wname, true,
778 ".xml", ".apl");
779
780 const int result = unlink(filename.c_str());
781 if (result)
782 {
783 out << wname << " NOT DROPPED: " << strerror(errno) << endl;
784 MORE_ERROR() << "could not unlink file " << filename;
785 }
786 else
787 {
788 Workspace::get_v_Quad_TZ().print_timestamp(out, now()) << endl;
789 }
790 }
791 //-----------------------------------------------------------------------------
792 void
cmd_DUMP(ostream & out,const UCS_string_vector & args,bool html,bool silent)793 Command::cmd_DUMP(ostream & out, const UCS_string_vector & args,
794 bool html, bool silent)
795 {
796 // Command is:
797 //
798 // )DUMP
799 // )DUMP workspace
800 // )DUMP lib workspace
801
802 if (args.size() > 0) // workspace or lib workspace
803 {
804 LibRef lib;
805 UCS_string wsname;
806 if (resolve_lib_wsname(out, args, lib, wsname)) return; // error
807 Workspace::dump_WS(out, lib, wsname, html, silent);
808 return;
809 }
810
811 // )DUMP: use )WSID unless CLEAR WS
812 //
813 LibRef wsid_lib = LIB0;
814 UCS_string wsid_name = Workspace::get_WS_name();
815 if (Avec::is_digit(wsid_name[0])) // wsid contains a libnum
816 {
817 wsid_lib = LibRef(wsid_name[0] - '0');
818 wsid_name.erase(0);
819 wsid_name.remove_leading_whitespaces();
820 }
821
822 if (wsid_name.compare(UCS_string("CLEAR WS")) == 0) // don't dump CLEAR WS
823 {
824 COUT << "NOT DUMPED: THIS WS IS CLEAR WS" << endl;
825 MORE_ERROR() <<
826 "the workspace was not dumped because 'CLEAR WS' is a special\n"
827 "workspace name that cannot be dumped. "
828 "First create WS name with )WSID <name>.";
829 return;
830 }
831
832 Workspace::dump_WS(out, wsid_lib, wsid_name, html, silent);
833 }
834 //-----------------------------------------------------------------------------
835 void
cmd_ERASE(ostream & out,UCS_string_vector & args)836 Command::cmd_ERASE(ostream & out, UCS_string_vector & args)
837 {
838 Workspace::erase_symbols(out, args);
839 }
840 //-----------------------------------------------------------------------------
841 void
cmd_KEYB(ostream & out)842 Command::cmd_KEYB(ostream & out)
843 {
844 // maybe print user-supplied keyboard layout file
845 //
846 if (uprefs.keyboard_layout_file.size())
847 {
848 FILE * layout = fopen(uprefs.keyboard_layout_file.c_str(), "r");
849 if (layout == 0)
850 {
851 out << "Could not open " << uprefs.keyboard_layout_file
852 << ": " << strerror(errno) << endl
853 << "Showing default layout instead" << endl;
854 }
855 else
856 {
857 out << "User-defined Keyboard Layout:\n";
858 for (;;)
859 {
860 const int cc = fgetc(layout);
861 if (cc == EOF) break;
862 out << char(cc);
863 }
864 out << endl;
865 return;
866 }
867 }
868
869 out << "US Keyboard Layout:\n"
870 "\n"
871 "╔════╦════╦════╦════╦════╦════╦════╦════╦════╦════╦════╦════╦════╦═════════╗\n"
872 "║ ~ ║ !⌶ ║ @⍫ ║ #⍒ ║ $⍋ ║ %⌽ ║ ^⍉ ║ &⊖ ║ *⍟ ║ (⍱ ║ )⍲ ║ _! ║ +⌹ ║ ║\n"
873 "║ `◊ ║ 1¨ ║ 2¯ ║ 3< ║ 4≤ ║ 5= ║ 6≥ ║ 7> ║ 8≠ ║ 9∨ ║ 0∧ ║ -× ║ =÷ ║ BACKSP ║\n"
874 "╠════╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦═╩══╦══════╣\n"
875 "║ ║ Q ║ W⍹ ║ E⋸ ║ R ║ T⍨ ║ Y¥ ║ U ║ I⍸ ║ O⍥ ║ P⍣ ║ {⍞ ║ }⍬ ║ |⊣ ║\n"
876 "║ TAB ║ q? ║ w⍵ ║ e∈ ║ r⍴ ║ t∼ ║ y↑ ║ u↓ ║ i⍳ ║ o○ ║ p⋆ ║ [← ║ ]→ ║ \\⊢ ║\n"
877 "╠═══════╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩═╦══╩══════╣\n"
878 "║ (CAPS ║ A⍶ ║ S ║ D ║ F ║ G ║ H ║ J⍤ ║ K ║ L⌷ ║ :≡ ║ \"≢ ║ ║\n"
879 "║ LOCK) ║ a⍺ ║ s⌈ ║ d⌊ ║ f_ ║ g∇ ║ h∆ ║ j∘ ║ k' ║ l⎕ ║ ;⍎ ║ '⍕ ║ RETURN ║\n"
880 "╠═════════╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═══╦╩═════════╣\n"
881 "║ ║ Z ║ Xχ ║ C¢ ║ V ║ B£ ║ N ║ M ║ <⍪ ║ >⍙ ║ ?⍠ ║ ║\n"
882 "║ SHIFT ║ z⊂ ║ x⊃ ║ c∩ ║ v∪ ║ b⊥ ║ n⊤ ║ m| ║ ,⍝ ║ .⍀ ║ /⌿ ║ SHIFT ║\n"
883 "╚═════════════╩════╩════╩════╩════╩════╩════╩════╩════╩════╩════╩══════════╝\n"
884 << endl;
885 }
886 //-----------------------------------------------------------------------------
887 void
cmd_PSTAT(ostream & out,const UCS_string & arg)888 Command::cmd_PSTAT(ostream & out, const UCS_string & arg)
889 {
890 #ifndef PERFORMANCE_COUNTERS_WANTED
891 out << "\n"
892 << "Command ]PSTAT is not available, since performance counters were not\n"
893 "configured for this APL interpreter. To enable performance counters (which\n"
894 "will slightly decrease performance), recompile the interpreter as follows:"
895
896 << "\n\n"
897 " ./configure PERFORMANCE_COUNTERS_WANTED=yes (... "
898 << "other configure options"
899 << ")\n"
900 " make\n"
901 " make install (or try: src/apl)\n"
902 "\n"
903
904 << "above the src directory."
905 << "\n";
906
907 return;
908 #endif
909
910 if (arg.starts_iwith("CLEAR"))
911 {
912 out << "Performance counters cleared" << endl;
913 Performance::reset_all();
914 return;
915 }
916
917 if (arg.starts_iwith("SAVE"))
918 {
919 const char * filename = "./PerformanceData.def";
920 ofstream outf(filename, ofstream::out);
921 if (!outf.is_open())
922 {
923 out << "opening " << filename
924 << " failed: " << strerror(errno) << endl;
925 return;
926 }
927
928 out << "Writing performance data to file " << filename << endl;
929 Performance::save_data(out, outf);
930 return;
931 }
932
933 Pfstat_ID iarg = PFS_ALL;
934 if (arg.size() > 0) iarg = Pfstat_ID(arg.atoi());
935
936 Performance::print(iarg, out);
937 }
938 //-----------------------------------------------------------------------------
939 void
primitive_help(ostream & out,const char * arg,int arity,const char * prim,const char * name,const char * brief,const char * descr)940 Command::primitive_help(ostream & out, const char * arg, int arity,
941 const char * prim, const char * name,
942 const char * brief, const char * descr)
943 {
944 if (strcmp(arg, prim)) return;
945
946 switch(arity)
947 {
948 case -5: out << " quasi-dyadic operator: Z ← A (∘ "
949 << prim << " G) B"; break;
950 case -4: out << " dyadic operator: Z ← A (F "
951 << prim << " G) B"; break;
952 case -3: out << " dyadic operator: Z ← (F "
953 << prim << " G) B"; break;
954 case -2: out << " monadic operator: Z ← A (F "
955 << prim << ") B"; break;
956 case -1: out << " monadic operator: Z ← (F "
957 << prim << ") B"; break;
958 case 0: out << " niladic function: Z ← " << prim; break;
959 case 1: out << " monadic function: Z ← " << prim << " B"; break;
960 case 2: out << " dyadic function: Z ← A " << prim << " B"; break;
961 default: FIXME;
962 }
963
964 out << " (" << name << ")" << endl
965 << " " << brief << endl;
966
967 if (descr) out << descr << endl;
968 }
969 //-----------------------------------------------------------------------------
970
971 /// return the lengt differece between a UCS_string and its UTF8 encoding
972 static inline int
len_diff(const char * txt)973 len_diff(const char * txt)
974 {
975 int ret = 0;
976 while (const char cc = *txt++) if ((cc & 0xC0) == 0x80) ++ret;
977 return ret;
978 }
979
980 void
cmd_HELP(ostream & out,const UCS_string & arg)981 Command::cmd_HELP(ostream & out, const UCS_string & arg)
982 {
983 if (arg.size() > 0 && Avec::is_first_symbol_char(arg[0]))
984 {
985 // help for a user defined name
986 //
987 CERR << "symbol " << arg << " ";
988 Symbol * sym = Workspace::lookup_existing_symbol(arg);
989 if (sym == 0)
990 {
991 CERR << "does not exist" << endl;
992 return;
993 }
994
995 if (sym->is_erased())
996 {
997 CERR << "is erased." << endl;
998 return;
999 }
1000
1001 ValueStackItem * vs = sym->top_of_stack();
1002 if (vs == 0)
1003 {
1004 CERR << " has no stack." << endl;
1005 return;
1006 }
1007
1008 switch(vs->name_class)
1009 {
1010 case NC_INVALID:
1011 CERR << "has no valid name class" << endl;
1012 return;
1013
1014 case NC_UNUSED_USER_NAME:
1015 CERR << "is an unused name" << endl;
1016 return;
1017
1018 case NC_LABEL:
1019 CERR << "is a label (line " << vs->sym_val.label
1020 << ")" << endl;
1021 return;
1022
1023 case NC_VARIABLE:
1024 {
1025 CERR << "is a variable:" << endl;
1026 Value_P val = sym->get_value();
1027 if (!!val)
1028 {
1029 val->print_properties(CERR, 4, true);
1030 }
1031 }
1032 CERR << endl;
1033 return;
1034
1035 case NC_FUNCTION:
1036 {
1037 Function * fun = sym->get_function();
1038 Assert(fun);
1039 if (fun->is_native())
1040 {
1041 const NativeFunction *nf =
1042 reinterpret_cast<const NativeFunction *>(fun);
1043 CERR << "is a native function implemented in "
1044 << nf->get_so_path() << endl
1045 << " load state: " << (nf->is_valid() ?
1046 "OK (loaded)" : "error") << endl;
1047 return;
1048 }
1049
1050 CERR << "is a ";
1051 if (fun->get_fun_valence() == 2) CERR << "dyadic";
1052 else if (fun->get_fun_valence() == 1) CERR << "monadic";
1053 else CERR << "niladic";
1054 CERR << " defined function:" << endl;
1055
1056 const UserFunction * ufun = fun->get_ufun1();
1057 Assert(ufun);
1058 ufun->help(CERR);
1059 }
1060 return;
1061
1062 case NC_OPERATOR:
1063 {
1064 Function * fun = sym->get_function();
1065 Assert(fun);
1066 CERR << "is a ";
1067 if (fun->get_oper_valence() == 2) CERR << "dyadic";
1068 else CERR << "monadic";
1069 CERR << " defined operator:" << endl;
1070
1071 const UserFunction * ufun = fun->get_ufun1();
1072 Assert(ufun);
1073 ufun->help(CERR);
1074 }
1075 return;
1076
1077 case NC_SHARED_VAR:
1078 CERR << "is a shared variable" << endl;
1079 return;
1080
1081 }
1082
1083 return;
1084 }
1085
1086 if (arg.size() == 1) // help for an APL primitive
1087 {
1088 UTF8_string arg_utf(arg);
1089 const char * arg_cp = arg_utf.c_str();
1090
1091 #define help_def(ar, prim, name, title, descr) \
1092 primitive_help(out, arg_cp, ar, prim, name, title, descr);
1093 #include "Help.def"
1094
1095 return;
1096 }
1097
1098 enum { COL2 = 40 }; ///< where the second column starts
1099
1100 UCS_string_vector commands;
1101 commands.reserve(60);
1102
1103 out << left << "APL Commands:" << endl;
1104 #define cmd_def(cmd_str, _cod, arg, _hint) \
1105 { UCS_string c(cmd_str " " arg); commands.push_back(c); }
1106 #include "Command.def"
1107
1108 bool left_col = true;
1109 loop(c, commands.size())
1110 {
1111 const UCS_string & cmd = commands[c];
1112 if (left_col)
1113 {
1114 out << " " << setw(COL2 - 2) << cmd;
1115 left_col = false;
1116 }
1117 else
1118 {
1119 out << cmd << endl;
1120 left_col = true;
1121 }
1122 }
1123
1124 if (Workspace::get_user_commands().size())
1125 {
1126 out << endl << "User defined commands:" << endl;
1127 loop(u, Workspace::get_user_commands().size())
1128 {
1129 out << " " << Workspace::get_user_commands()[u].prefix
1130 << " [args] calls: ";
1131 if (Workspace::get_user_commands()[u].mode)
1132 out << "tokenized-args ";
1133
1134 out << Workspace::get_user_commands()[u].apl_function
1135 << " quoted-args" << endl;
1136 }
1137 }
1138
1139 out << endl << "System variables:" << endl
1140 << " " << setw(COL2)
1141 << "⍞ Character Input/Output"
1142 << "⎕ Evaluated Input/Output" << endl;
1143 left_col = true;
1144 #define ro_sv_def(x, _str, txt) \
1145 { const UCS_string & ucs = Workspace::get_v_ ## x().get_name(); \
1146 if (left_col) out << " " << setw(8) << ucs << setw(30) << txt; \
1147 else out << setw(8) << ucs << txt << endl; \
1148 left_col = !left_col; }
1149 #define rw_sv_def(x, str, txt) ro_sv_def(x, str, txt)
1150 #include "SystemVariable.def"
1151
1152 out << endl << "System functions:" << endl;
1153 left_col = true;
1154 #define ro_sv_def(x, _str, _txt)
1155 #define rw_sv_def(x, _str, _txt)
1156 #define sf_def(_q, str, txt) \
1157 if (left_col) out << " ⎕" << setw(7) << str << setw(30 + \
1158 len_diff(txt)) << txt; \
1159 else out << "⎕" << setw(7) << str << txt << endl; \
1160 left_col = !left_col;
1161 #include "SystemVariable.def"
1162 }
1163 //-----------------------------------------------------------------------------
1164 void
cmd_HISTORY(ostream & out,const UCS_string & arg)1165 Command::cmd_HISTORY(ostream & out, const UCS_string & arg)
1166 {
1167 if (arg.size() == 0) LineInput::print_history(out);
1168 else if (arg.starts_iwith("CLEAR")) LineInput::clear_history(out);
1169 else out << "BAD COMMAND" << endl;
1170 }
1171 //-----------------------------------------------------------------------------
1172 void
cmd_HOST(ostream & out,const UCS_string & arg)1173 Command::cmd_HOST(ostream & out, const UCS_string & arg)
1174 {
1175 if (uprefs.safe_mode)
1176 {
1177 out <<
1178 "This interpreter was started in \"safe mode\" (command line option --safe,\n"
1179 "see ⎕ARG). The APL command )HOST is not permitted in safe mode." << endl;
1180 return;
1181 }
1182
1183 UTF8_string host_cmd(arg);
1184 FILE * pipe = popen(host_cmd.c_str(), "r");
1185 if (pipe == 0) // popen() failed
1186 {
1187 out << ")HOST command failed: " << strerror(errno) << endl;
1188 return;
1189 }
1190
1191 for (;;)
1192 {
1193 const int cc = fgetc(pipe);
1194 if (cc == EOF) break;
1195 out << char(cc);
1196 }
1197
1198 int result = pclose(pipe);
1199 Log(LOG_verbose_error)
1200 {
1201 if (result) CERR << "pclose(" << arg << ") says: "
1202 << strerror(errno) << endl;
1203 }
1204 out << endl << IntCell(result) << endl;
1205 }
1206 //-----------------------------------------------------------------------------
1207 void
cmd_IN(ostream & out,UCS_string_vector & args,bool protection)1208 Command::cmd_IN(ostream & out, UCS_string_vector & args, bool protection)
1209 {
1210 // Command is:
1211 //
1212 // IN filename [objects...]
1213
1214 UCS_string fname = args[0];
1215 args[0] = args.back();
1216 args.pop_back();
1217
1218 UTF8_string filename = LibPaths::get_lib_filename(LIB_NONE, fname, true,
1219 ".atf", 0);
1220
1221 FILE * in = fopen(filename.c_str(), "r");
1222 if (in == 0) // open failed: try filename.atf unless already .atf
1223 {
1224 UTF8_string fname_utf8(fname);
1225 CERR << ")IN " << fname_utf8.c_str()
1226 << " failed: " << strerror(errno) << endl;
1227
1228 char cc[200];
1229 snprintf(cc, sizeof(cc),
1230 "command )IN: could not open file %s for reading: %s",
1231 fname_utf8.c_str(), strerror(errno));
1232 Workspace::more_error() << cc;
1233 return;
1234 }
1235
1236 UTF8 buffer[80];
1237 int idx = 0;
1238
1239 transfer_context tctx(protection);
1240
1241 for (;;)
1242 {
1243 const int cc = fgetc(in);
1244 if (cc == EOF) break;
1245 if (idx == 0 && cc == 0x0A) // optional LF
1246 {
1247 // CERR << "CRLF" << endl;
1248 continue;
1249 }
1250
1251 if (idx < 80)
1252 {
1253 if (idx < 72) buffer[idx++] = cc;
1254 else buffer[idx++] = 0;
1255 continue;
1256 }
1257
1258 if (cc == 0x0D || cc == 0x15) // ASCII or EBCDIC
1259 {
1260 tctx.is_ebcdic = (cc == 0x15);
1261 tctx.process_record(buffer, args);
1262
1263 idx = 0;
1264 ++tctx.recnum;
1265 continue;
1266 }
1267
1268 CERR << "BAD record charset (neither ASCII nor EBCDIC)" << endl;
1269 break;
1270 }
1271
1272 fclose(in);
1273 }
1274 //-----------------------------------------------------------------------------
1275 void
cmd_LOAD(ostream & out,UCS_string_vector & args,UCS_string & quad_lx,bool silent)1276 Command::cmd_LOAD(ostream & out, UCS_string_vector & args,
1277 UCS_string & quad_lx, bool silent)
1278 {
1279 // Command is:
1280 //
1281 // LOAD wsname
1282 // LOAD libnum wsname
1283
1284 LibRef lib;
1285 UCS_string wsname;
1286 if (resolve_lib_wsname(out, args, lib, wsname)) return; // error
1287
1288 Workspace::load_WS(out, lib, wsname, quad_lx, silent);
1289 }
1290 //-----------------------------------------------------------------------------
1291 void
cmd_LIBS(ostream & out,const UCS_string_vector & args)1292 Command::cmd_LIBS(ostream & out, const UCS_string_vector & args)
1293 {
1294 // Command is:
1295 //
1296 // )LIB N path (set libdir N to path)
1297 // )LIB path (set libroot to path)
1298 // )LIB (display root and path states)
1299 //
1300 if (args.size() == 2) // set individual dir
1301 {
1302 const UCS_string & libref_ucs = args[0];
1303 const int libref = libref_ucs[0] - '0';
1304 if (libref_ucs.size() != 1 || libref < 0 || libref > 9)
1305 {
1306 CERR << "Invalid library reference " << libref_ucs << "'" << endl;
1307 return;
1308 }
1309
1310 UTF8_string path(args[1]);
1311 LibPaths::set_lib_dir(LibRef(libref), path.c_str(),
1312 LibPaths::LibDir::CSRC_CMD);
1313 out << "LIBRARY REFERENCE " << libref << " SET TO " << path << endl;
1314 return;
1315 }
1316
1317 if (args.size() == 1) // set root
1318 {
1319 UTF8_string utf(args[0]);
1320 LibPaths::set_APL_lib_root(utf.c_str());
1321 out << "LIBRARY ROOT SET TO " << args[0] << endl;
1322 return;
1323 }
1324
1325 out << "Library root: " << LibPaths::get_APL_lib_root() <<
1326 "\n"
1327 "\n"
1328 "Library reference number mapping:\n"
1329 "\n"
1330 "---------------------------------------------------------------------------\n"
1331 "Ref Conf Path State Err\n"
1332 "---------------------------------------------------------------------------\n";
1333
1334
1335 loop(d, 10)
1336 {
1337 UTF8_string path = LibPaths::get_lib_dir(LibRef(d));
1338 out << " " << d << " ";
1339 switch(LibPaths::get_cfg_src(LibRef(d)))
1340 {
1341 case LibPaths::LibDir::CSRC_NONE: out << "NONE" << endl;
1342 continue;
1343 case LibPaths::LibDir::CSRC_ENV: out << "ENV "; break;
1344 case LibPaths::LibDir::CSRC_PWD: out << "PWD "; break;
1345 case LibPaths::LibDir::CSRC_PREF_SYS: out << "PSYS "; break;
1346 case LibPaths::LibDir::CSRC_PREF_HOME: out << "PUSER "; break;
1347 case LibPaths::LibDir::CSRC_CMD: out << "CMD "; break;
1348 }
1349
1350 out << left << setw(52) << path.c_str();
1351 DIR * dir = opendir(path.c_str());
1352 if (dir) { out << " present" << endl; closedir(dir); }
1353 else { out << " missing (" << errno << ")" << endl; }
1354 }
1355
1356 out <<
1357 "===========================================================================\n" << endl;
1358 }
1359 //-----------------------------------------------------------------------------
1360 DIR *
open_LIB_dir(UTF8_string & path,ostream & out,const UCS_string_vector & args)1361 Command::open_LIB_dir(UTF8_string & path, ostream & out,
1362 const UCS_string_vector & args)
1363 {
1364 // args can be one of:
1365 // example:
1366 // 1. )LIB
1367 // 2. N )LIB 1
1368 // 3. )LIB directory-name )LIB /usr/lib/...
1369 //
1370
1371 UCS_string arg("0");
1372 if (args.size()) arg = args[0];
1373
1374 if (args.size() == 0) // case 1.
1375 {
1376 path = LibPaths::get_lib_dir(LIB0);
1377 }
1378 else if (arg.size() == 1 &&
1379 Avec::is_digit(Unicode(arg[0]))) // case 2.
1380 {
1381 path = LibPaths::get_lib_dir(LibRef(arg[0] - '0'));
1382 }
1383 else // case 3.
1384 {
1385 path = UTF8_string(arg);
1386 }
1387
1388 // follow symbolic links, but not too often (because symbolic links may
1389 // form an endless loop)...
1390 //
1391 loop(depth, 20)
1392 {
1393 char buffer[FILENAME_MAX + 1];
1394 const ssize_t len = readlink(path.c_str(), buffer, FILENAME_MAX);
1395 if (len <= 0) break; // not a symlink
1396
1397 buffer[len] = 0;
1398 if (buffer[0] == '/') // absolute path
1399 {
1400 path = UTF8_string(buffer);
1401 }
1402 else // relative path
1403 {
1404 path += '/';
1405 path.append_UTF8(UTF8_string(buffer));
1406 }
1407 }
1408
1409 DIR * dir = opendir(path.c_str());
1410
1411 if (dir == 0)
1412 {
1413 const char * why = strerror(errno);
1414 out << "IMPROPER LIBRARY REFERENCE '" << arg << "': " << why << endl;
1415
1416 MORE_ERROR() <<
1417 "path '" << path << "' could not be opened as directory: " << why;
1418 return 0; // error
1419 }
1420
1421 return dir;
1422 }
1423 //-----------------------------------------------------------------------------
1424 bool
is_directory(dirent * entry,const UTF8_string & path)1425 Command::is_directory(dirent * entry, const UTF8_string & path)
1426 {
1427 #ifdef _DIRENT_HAVE_D_TYPE
1428 return entry->d_type == DT_DIR;
1429 #endif
1430
1431 UTF8_string filename = path;
1432 UTF8_string entry_name(entry->d_name);
1433 filename += '/';
1434 filename.append_UTF8(entry_name);
1435
1436 DIR * dir = opendir(filename.c_str());
1437 if (dir) closedir(dir);
1438 return dir != 0;
1439 }
1440 //-----------------------------------------------------------------------------
1441 void
lib_common(ostream & out,const UCS_string_vector & args_range,int variant)1442 Command::lib_common(ostream & out, const UCS_string_vector & args_range,
1443 int variant)
1444 {
1445 // 1. check for (and then extract) an optional range parameter...
1446 //
1447 UCS_string_vector args;
1448 const UCS_string * range = 0;
1449 loop(a, args_range.size())
1450 {
1451 const UCS_string & arg = args_range[a];
1452 bool is_range = false;
1453 bool is_path = false;
1454 loop(aa, arg.size())
1455 {
1456 const Unicode uni = arg[aa];
1457 if (uni == UNI_ASCII_MINUS)
1458 {
1459 is_range = true;
1460 break;
1461 }
1462
1463 if (!Avec::is_symbol_char(uni))
1464 {
1465 is_path = true;
1466 break;
1467 }
1468 }
1469
1470 if (is_path) // normal (non-range) arg
1471 {
1472 args.push_back(arg);
1473 }
1474 else if (!is_range) // normal (non-range) arg
1475 {
1476 args.push_back(arg);
1477 }
1478 else if (range) // second non-range arg
1479 {
1480 MORE_ERROR() <<
1481 "multiple range parameters in )LIB or ]LIB command";
1482 return;
1483 }
1484 else
1485 {
1486 range = &arg;
1487 }
1488 }
1489
1490 UCS_string from;
1491 UCS_string to;
1492 if (range)
1493 {
1494 const bool bad_from_to = parse_from_to(from, to, *range);
1495 if (bad_from_to)
1496 {
1497 CERR << "bad range argument" << endl;
1498 MORE_ERROR() << "bad range argument " << *range
1499 << ", expecting from-to";
1500 return;
1501 }
1502 }
1503
1504 // 2. open directory
1505 //
1506 UTF8_string path;
1507 DIR * dir = open_LIB_dir(path, out, args);
1508 if (dir == 0) return;
1509
1510 // 3. collect files and directories
1511 //
1512 UCS_string_vector files;
1513 UCS_string_vector directories;
1514
1515 for (;;)
1516 {
1517 dirent * entry = readdir(dir);
1518 if (entry == 0) break; // directory done
1519
1520 UTF8_string filename_utf8(entry->d_name);
1521 UCS_string filename(filename_utf8);
1522
1523 // check range (if any)...
1524 //
1525 if (from.size() && filename.lexical_before(from)) continue;
1526 if (to.size() && to.lexical_before(filename)) continue;
1527
1528 if (is_directory(entry, path))
1529 {
1530 if (filename_utf8[0] == '.') continue;
1531 filename.append(UNI_ASCII_SLASH);
1532 directories.push_back(filename);
1533 continue;
1534 }
1535
1536 const int dlen = strlen(entry->d_name);
1537 if (variant == 1)
1538 {
1539 if (filename_utf8.ends_with(".apl"))
1540 {
1541 filename.resize(filename.size() - 4); // skip extension
1542 files.push_back(filename);
1543 }
1544 else if (filename_utf8.ends_with(".xml"))
1545 {
1546 filename.resize(filename.size() - 4); // skip extension
1547 files.push_back(filename);
1548 }
1549 }
1550 else
1551 {
1552 if (filename[0] == '.') continue; // skip dot files
1553 if (filename[dlen - 1] == '~') continue; // and editor backups
1554 files.push_back(filename);
1555 }
1556 }
1557 closedir(dir);
1558
1559 // 4. sort directories and filenames alphabetically and append files
1560 // to directories
1561 //
1562 directories.sort();
1563 files.sort();
1564 loop(f, files.size())
1565 {
1566 if (directories.size() && directories.back() == files[f])
1567 {
1568 // there were some file.apl and file.xml. Skip the second
1569 //
1570 continue;
1571 }
1572 directories.push_back(files[f]);
1573 }
1574
1575 // 5. list directories first, then files
1576 //
1577
1578 // figure column widths
1579 //
1580 enum { tabsize = 4 };
1581
1582 std::vector<int> col_widths;
1583 directories.compute_column_width(tabsize, col_widths);
1584
1585 loop(c, directories.size())
1586 {
1587 const size_t col = c % col_widths.size();
1588 out << directories[c];
1589 if (col == size_t(col_widths.size() - 1) ||
1590 c == ShapeItem(directories.size() - 1))
1591 {
1592 // last column or last item: print newline
1593 //
1594 out << endl;
1595 }
1596 else
1597 {
1598 // intermediate column: print spaces
1599 //
1600 const int len = tabsize*col_widths[col] - directories[c].size();
1601 Assert(len > 0);
1602 loop(l, len) out << " ";
1603 }
1604 }
1605 }
1606 //-----------------------------------------------------------------------------
1607 void
cmd_LIB1(ostream & out,const UCS_string_vector & args)1608 Command::cmd_LIB1(ostream & out, const UCS_string_vector & args)
1609 {
1610 // Command is:
1611 //
1612 // )LIB (same as )LIB 0)
1613 // )LIB N (show workspaces in library N without extensions)
1614 // )LIB from-to (show workspaces named from-to in library 0
1615 // )LIB N from-to (show workspaces named from-to in library N
1616
1617 Command::lib_common(out, args, 1);
1618 }
1619 //-----------------------------------------------------------------------------
1620 void
cmd_LIB2(ostream & out,const UCS_string_vector & args)1621 Command::cmd_LIB2(ostream & out, const UCS_string_vector & args)
1622 {
1623 // Command is:
1624 //
1625 // ]LIB (same as )LIB 0)
1626 // ]LIB N (show workspaces in library N with extensions)
1627 // ]LIB from-to (show workspaces named from-to in library 0
1628 // ]LIB N from-to (show workspaces named from-to in library N
1629
1630 Command::lib_common(out, args, 2);
1631 }
1632 //-----------------------------------------------------------------------------
1633 void
cmd_LOG(ostream & out,const UCS_string & arg)1634 Command::cmd_LOG(ostream & out, const UCS_string & arg)
1635 {
1636 #ifdef DYNAMIC_LOG_WANTED
1637
1638 log_control(arg);
1639
1640 #else
1641
1642 out <<
1643 "\n"
1644 "Command ]LOG is not available, since dynamic logging was not\n"
1645 "configured for this APL interpreter. To enable dynamic logging (which\n"
1646 "will slightly decrease performance), recompile the interpreter as follows:\n"
1647 "\n"
1648 " ./configure DYNAMIC_LOG_WANTED=yes (... other configure options)\n"
1649 " make\n"
1650 " make install (or try: src/apl)\n"
1651 "\n"
1652 "above the src directory."
1653 "\n";
1654
1655 #endif
1656 }
1657 //-----------------------------------------------------------------------------
1658 void
cmd_MORE(ostream & out)1659 Command::cmd_MORE(ostream & out)
1660 {
1661 if (Workspace::more_error().size() == 0)
1662 {
1663 out << "NO MORE ERROR INFO" << endl;
1664 return;
1665 }
1666
1667 out << Workspace::more_error() << endl;
1668 return;
1669 }
1670 //-----------------------------------------------------------------------------
1671 void
cmd_OFF(int exit_val)1672 Command::cmd_OFF(int exit_val)
1673 {
1674 cleanup(true);
1675 COUT << endl;
1676 if (!uprefs.silent)
1677 {
1678
1679 timeval end;
1680 gettimeofday(&end, 0);
1681 end.tv_sec -= uprefs.session_start.tv_sec;
1682 end.tv_usec -= uprefs.session_start.tv_usec;
1683 if (end.tv_usec < 1000000) { end.tv_usec += 1000000; --end.tv_sec; }
1684 COUT << "Goodbye." << endl
1685 << "Session duration: " << (end.tv_sec + 0.000001*end.tv_usec)
1686 << " seconds " << endl;
1687
1688 }
1689
1690 // restore the initial memory rlimit
1691 //
1692 #ifndef RLIMIT_AS // BSD does not define RLIMIT_AS
1693 # define RLIMIT_AS RLIMIT_DATA
1694 #endif
1695
1696 rlimit rl;
1697 getrlimit(RLIMIT_AS, &rl);
1698 rl.rlim_cur = Quad_WA::initial_rlimit;
1699 setrlimit(RLIMIT_AS, &rl);
1700
1701 exit(exit_val);
1702 }
1703 //-----------------------------------------------------------------------------
1704 void
cmd_OUT(ostream & out,UCS_string_vector & args)1705 Command::cmd_OUT(ostream & out, UCS_string_vector & args)
1706 {
1707 UCS_string fname = args[0];
1708 args.erase(args.begin());
1709
1710 UTF8_string filename = LibPaths::get_lib_filename(LIB_NONE, fname, false,
1711 ".atf", 0);
1712
1713 FILE * atf = fopen(filename.c_str(), "w");
1714 if (atf == 0)
1715 {
1716 const char * why = strerror(errno);
1717 out << ")OUT " << fname << " failed: " << why << endl;
1718 MORE_ERROR() << "command )OUT: could not open file " << fname
1719 << " for writing: " << why;
1720 return;
1721 }
1722
1723 uint64_t seq = 1; // sequence number for records written
1724 Workspace::write_OUT(atf, seq, args);
1725
1726 fclose(atf);
1727 }
1728 //-----------------------------------------------------------------------------
1729 bool
check_name_conflict(ostream & out,const UCS_string & cnew,const UCS_string cold)1730 Command::check_name_conflict(ostream & out, const UCS_string & cnew,
1731 const UCS_string cold)
1732 {
1733 int len = cnew.size();
1734 if (len > cold.size()) len = cold.size();
1735
1736 loop(l, len)
1737 {
1738 int c1 = cnew[l];
1739 int c2 = cold[l];
1740 if (c1 >= 'a' && c1 <= 'z') c1 -= 0x20; // uppercase
1741 if (c2 >= 'a' && c2 <= 'z') c2 -= 0x20; // uppercase
1742 if (l && (c1 != c2)) return false; // OK: different
1743 }
1744
1745 out << "BAD COMMAND+" << endl;
1746 MORE_ERROR() << "conflict with existing command name in command ]USERCMD";
1747
1748 return true;
1749 }
1750 //-----------------------------------------------------------------------------
1751 bool
check_redefinition(ostream & out,const UCS_string & cnew,const UCS_string fnew,const int mnew)1752 Command::check_redefinition(ostream & out, const UCS_string & cnew,
1753 const UCS_string fnew, const int mnew)
1754 {
1755 loop(u, Workspace::get_user_commands().size())
1756 {
1757 const UCS_string cold = Workspace::get_user_commands()[u].prefix;
1758 const UCS_string fold = Workspace::get_user_commands()[u].apl_function;
1759 const int mold = Workspace::get_user_commands()[u].mode;
1760
1761 if (cnew != cold) continue;
1762
1763 // user command name matches; so must mode and function
1764 if (mnew != mold || fnew != fold)
1765 {
1766 out << "BAD COMMAND" << endl;
1767 MORE_ERROR() <<
1768 "conflict with existing user command definition in command ]USERCMD";
1769 }
1770 return true;
1771 }
1772
1773 return false;
1774 }
1775 //-----------------------------------------------------------------------------
1776 void
cmd_SAVE(ostream & out,const UCS_string_vector & args)1777 Command::cmd_SAVE(ostream & out, const UCS_string_vector & args)
1778 {
1779 // )SAVE
1780 // )SAVE workspace
1781 // )SAVE lib workspace
1782
1783 if (args.size() > 0) // workspace or lib workspace
1784 {
1785 LibRef lib;
1786 UCS_string wsname;
1787 if (resolve_lib_wsname(out, args, lib, wsname)) return; // error
1788 Workspace::save_WS(out, lib, wsname, false);
1789 return;
1790 }
1791
1792 // )SAVE without arguments: use )WSID unless CLEAR WS
1793 //
1794 LibRef wsid_lib = LIB0;
1795 UCS_string wsid_name = Workspace::get_WS_name();
1796 if (Avec::is_digit(wsid_name[0])) // wsid contains a libnum
1797 {
1798 wsid_lib = LibRef(wsid_name[0] - '0');
1799 wsid_name.erase(0);
1800 wsid_name.remove_leading_whitespaces();
1801 }
1802
1803 if (wsid_name.compare(UCS_string("CLEAR WS")) == 0) // don't save CLEAR WS
1804 {
1805 COUT << "NOT SAVED: THIS WS IS CLEAR WS" << endl;
1806 MORE_ERROR() <<
1807 "the workspace was not saved because 'CLEAR WS' is a special\n"
1808 "workspace name that cannot be saved. "
1809 "First create WS name with )WSID <name>.";
1810 return;
1811 }
1812
1813 Workspace::save_WS(out, wsid_lib, wsid_name, true);
1814 }
1815 //-----------------------------------------------------------------------------
1816 bool
resolve_lib_wsname(ostream & out,const UCS_string_vector & args,LibRef & lib,UCS_string & wsname)1817 Command::resolve_lib_wsname(ostream & out, const UCS_string_vector & args,
1818 LibRef &lib, UCS_string & wsname)
1819 {
1820 Assert(args.size() > 0);
1821 if (args.size() == 1) // name without libnum
1822 {
1823 lib = LIB0;
1824 wsname = args[0];
1825 return false; // OK
1826 }
1827
1828 if (!(args[0].size() == 1 && Avec::is_digit(args[0][0])))
1829 {
1830 out << "BAD COMMAND+" << endl;
1831 MORE_ERROR() << "invalid library reference '" << args[0] << "'";
1832 return true; // error
1833 }
1834
1835 lib = LibRef(args[0][0] - '0');
1836 wsname = args[1];
1837 return false; // OK
1838 }
1839 //-----------------------------------------------------------------------------
1840 void
cmd_USERCMD(ostream & out,const UCS_string & cmd,UCS_string_vector & args)1841 Command::cmd_USERCMD(ostream & out, const UCS_string & cmd,
1842 UCS_string_vector & args)
1843 {
1844 // ]USERCMD
1845 // ]USERCMD REMOVE-ALL
1846 // ]USERCMD REMOVE ]existing-command
1847 // ]USERCMD ]new-command APL-fun
1848 // ]USERCMD ]new-command APL-fun mode
1849 // ]USERCMD ]new-command { ... }
1850 //
1851 if (args.size() == 0)
1852 {
1853 if (Workspace::get_user_commands().size())
1854 {
1855 loop(u, Workspace::get_user_commands().size())
1856 {
1857 out << Workspace::get_user_commands()[u].prefix << " → ";
1858 if (Workspace::get_user_commands()[u].mode) out << "A ";
1859 out << Workspace::get_user_commands()[u].apl_function << " B"
1860 << " (mode " << Workspace::get_user_commands()[u].mode
1861 << ")" << endl;
1862 }
1863 }
1864 return;
1865 }
1866
1867 if (args.size() == 1 && args[0].starts_iwith("REMOVE-ALL"))
1868 {
1869 Workspace::get_user_commands().clear();
1870 out << " All user-defined commands removed." << endl;
1871 return;
1872 }
1873
1874 if (args.size() == 2 && args[0].starts_iwith("REMOVE"))
1875 {
1876 loop(u, Workspace::get_user_commands().size())
1877 {
1878 if (Workspace::get_user_commands()[u].prefix
1879 .starts_iwith(args[1]) &&
1880 args[1].starts_iwith(Workspace::get_user_commands()[u]
1881 .prefix)) // same
1882 {
1883 // print first and remove then!
1884 //
1885 out << " User-defined command "
1886 << Workspace::get_user_commands()[u].prefix
1887 << " removed." << endl;
1888 Workspace::get_user_commands().
1889 erase(Workspace::get_user_commands().begin() + u);
1890 return;
1891 }
1892 }
1893
1894 out << "BAD COMMAND+" << endl;
1895 MORE_ERROR() << "user command in command ]USERCMD REMOVE does not exist";
1896 return;
1897 }
1898
1899 // check if the user command is not followed by the string
1900 if (args.size() == 1)
1901 {
1902 out << "BAD COMMAND+" << endl;
1903 MORE_ERROR() << "user command syntax in ]USERCMD:"
1904 " ]new-command APL-fun [mode]";
1905 return;
1906 }
1907
1908 UCS_string command_name = args[0];
1909 UCS_string apl_fun = args[1];
1910 int mode = 0;
1911
1912 // check if lambda
1913 bool is_lambda = false;
1914 if (apl_fun[0] == '{')
1915 {
1916 // looks like the user command is a lambda function.
1917 UCS_string result;
1918 // lambdas could contain spaces, collect all arguments in one string
1919 for (size_t i = 1; i < args.size(); ++i)
1920 {
1921 result << args[i];
1922 }
1923 // check if lamda-function closed properly
1924 if (result.back() == '}')
1925 {
1926 is_lambda = true;
1927 apl_fun = result;
1928 // determine the mode: if both alpha and omega present then
1929 // assume dyadic, otherwise monadic usage
1930 mode = (apl_fun.contains(UNI_OMEGA) &&
1931 apl_fun.contains(UNI_ALPHA)) ? 1 : 0;
1932 }
1933 else
1934 {
1935 out << "BAD COMMAND+" << endl;
1936 MORE_ERROR() << "closing } in lambda function not found";
1937 return;
1938 }
1939 }
1940
1941 if (args.size() > 3 && !is_lambda)
1942 {
1943 out << "BAD COMMAND+" << endl;
1944 MORE_ERROR() << "too many parameters in command ]USERCMD";
1945 return;
1946 }
1947
1948 // check mode
1949 if (!is_lambda && args.size() == 3) mode = args[2].atoi();
1950 if (mode < 0 || mode > 1)
1951 {
1952 out << "BAD COMMAND+" << endl;
1953 MORE_ERROR() << "unsupported mode " << mode
1954 << " in command ]USERCMD (0 or 1 expected)";
1955 return;
1956 }
1957
1958 // check command name
1959 //
1960 loop(c, command_name.size())
1961 {
1962 bool error = false;
1963 if (c == 0) error = error || command_name[c] != ']';
1964 else error = error || !Avec::is_symbol_char(command_name[c]);
1965 if (error)
1966 {
1967 out << "BAD COMMAND+" << endl;
1968 MORE_ERROR() << " bad user command name in command ]USERCMD";
1969 return;
1970 }
1971 }
1972
1973 // check conflicts with existing commands
1974 //
1975 #define cmd_def(cmd_str, _cod, _arg, _hint) \
1976 if (check_name_conflict(out, cmd_str, command_name)) return;
1977 #include "Command.def"
1978 if (check_redefinition(out, command_name, apl_fun, mode))
1979 {
1980 out << " User-defined command "
1981 << command_name << " installed." << endl;
1982 return;
1983 }
1984
1985 // check APL function name
1986 // Only needed when not a lambda function
1987 if (!is_lambda)
1988 {
1989 loop(c, apl_fun.size())
1990 {
1991 if (!Avec::is_symbol_char(apl_fun[c]))
1992 {
1993 out << "BAD COMMAND+" << endl;
1994 MORE_ERROR() <<
1995 "bad APL function name in command ]USERCMD";
1996 return;
1997 }
1998 }
1999 }
2000
2001 user_command new_user_command = { command_name, apl_fun, mode };
2002 Workspace::get_user_commands().push_back(new_user_command);
2003
2004 out << " User-defined command "
2005 << new_user_command.prefix << " installed." << endl;
2006 }
2007 //-----------------------------------------------------------------------------
2008 void
do_USERCMD(ostream & out,UCS_string & apl_cmd,const UCS_string & line,const UCS_string & cmd,UCS_string_vector & args,int uidx)2009 Command::do_USERCMD(ostream & out, UCS_string & apl_cmd,
2010 const UCS_string & line, const UCS_string & cmd,
2011 UCS_string_vector & args, int uidx)
2012 {
2013 if (Workspace::get_user_commands()[uidx].mode > 0) // dyadic
2014 {
2015 apl_cmd.append_quoted(cmd);
2016 apl_cmd.append(UNI_ASCII_SPACE);
2017 loop(a, args.size())
2018 {
2019 apl_cmd.append_quoted(args[a]);
2020 apl_cmd.append(UNI_ASCII_SPACE);
2021 }
2022 }
2023
2024 apl_cmd.append(Workspace::get_user_commands()[uidx].apl_function);
2025 apl_cmd.append(UNI_ASCII_SPACE);
2026 apl_cmd.append_quoted(line);
2027 }
2028 //-----------------------------------------------------------------------------
2029 #ifdef DYNAMIC_LOG_WANTED
2030 void
log_control(const UCS_string & arg)2031 Command::log_control(const UCS_string & arg)
2032 {
2033 UCS_string_vector args = split_arg(arg);
2034
2035 if (args.size() == 0 || arg[0] == UNI_ASCII_QUESTION) // no arg or '?'
2036 {
2037 for (LogId l = LID_MIN; l < LID_MAX; l = LogId(l + 1))
2038 {
2039 const char * info = Log_info(l);
2040 Assert(info);
2041
2042 const bool val = Log_status(l);
2043 CERR << " " << setw(2) << right << l << ": "
2044 << (val ? "(ON) " : "(OFF) ") << left << info << endl;
2045 }
2046
2047 return;
2048 }
2049
2050 const LogId val = LogId(args[0].atoi());
2051 int on_off = -1;
2052 if (args.size() > 1 && args[1].starts_iwith("ON")) on_off = 1;
2053 else if (args.size() > 1 && args[1].starts_iwith("OFf")) on_off = 0;
2054
2055 if (val >= LID_MIN && val <= LID_MAX)
2056 {
2057 const char * info = Log_info(val);
2058 Assert(info);
2059 bool new_status = !Log_status(val); // toggle
2060 if (on_off == 0) new_status = false;
2061 else if (on_off == 1) new_status = true;
2062
2063 Log_control(val, new_status);
2064 CERR << " Log facility '" << info << "' is now "
2065 << (new_status ? "ON " : "OFF") << endl;
2066 }
2067 }
2068 #endif
2069 //-----------------------------------------------------------------------------
2070 void
process_record(const UTF8 * record,const UCS_string_vector & objects)2071 Command::transfer_context::process_record(const UTF8 * record,
2072 const UCS_string_vector & objects)
2073 {
2074 const char rec_type = record[0]; // '*', ' ', or 'X'
2075 const char sub_type = record[1];
2076
2077 if (rec_type == '*') // comment or similar
2078 {
2079 Log(LOG_command_IN)
2080 {
2081 const char * stype = " *** bad sub-record of *";
2082 switch(sub_type)
2083 {
2084 case ' ': stype = " comment"; break;
2085 case '(': {
2086 stype = " timestamp";
2087 YMDhmsu t(now()); // fallback if sscanf() != 7
2088 if (7 == sscanf(charP(record + 1),
2089 "(%d %d %d %d %d %d %d)",
2090 &t.year, &t.month, &t.day,
2091 &t.hour, &t.minute, &t.second,
2092 &t.micro))
2093 {
2094 timestamp = t.get();
2095 }
2096 }
2097 break;
2098 case 'I': stype = " imbed"; break;
2099 }
2100
2101 CERR << "record #" << setw(3) << recnum << ": '" << rec_type
2102 << "'" << stype << endl;
2103 }
2104 }
2105 else if (rec_type == ' ' || rec_type == 'X') // object
2106 {
2107 if (new_record)
2108 {
2109 Log(LOG_command_IN)
2110 {
2111 const char * stype = " *** bad sub-record of X";
2112
2113 // " -------------------------------------";
2114 switch(sub_type)
2115 {
2116 case 'A': stype = " 2 ⎕TF array "; break;
2117 case 'C': stype = " 1 ⎕TF char array "; break;
2118 case 'F': stype = " 2 ⎕TF function "; break;
2119 case 'N': stype = " 1 ⎕TF numeric array "; break;
2120 }
2121
2122 CERR << "record #" << setw(3) << recnum
2123 << ": " << stype << endl;
2124 }
2125
2126 item_type = sub_type;
2127 }
2128
2129 add(record + 1, 71);
2130
2131 new_record = (rec_type == 'X'); // 'X' marks the final record
2132 if (new_record)
2133 {
2134 if (item_type == 'A') array_2TF(objects);
2135 else if (item_type == 'C') chars_1TF(objects);
2136 else if (item_type == 'N') numeric_1TF(objects);
2137 else if (item_type == 'F') function_2TF(objects);
2138 else CERR << "????: " << data << endl;
2139 data.clear();
2140 }
2141 }
2142 else
2143 {
2144 CERR << "record #" << setw(3) << recnum << ": '" << rec_type << "'"
2145 << "*** bad record type '" << rec_type << endl;
2146 }
2147 }
2148 //-----------------------------------------------------------------------------
2149 uint32_t
get_nrs(UCS_string & name,Shape & shape) const2150 Command::transfer_context::get_nrs(UCS_string & name, Shape & shape) const
2151 {
2152 int idx = 1;
2153
2154 // data + 1 is: NAME RK SHAPE RAVEL...
2155 //
2156 while (idx < data.size() && data[idx] != UNI_ASCII_SPACE)
2157 name.append(data[idx++]);
2158 ++idx; // skip space after the name
2159
2160 int rank = 0;
2161 while (idx < data.size() &&
2162 data[idx] >= UNI_ASCII_0 &&
2163 data[idx] <= UNI_ASCII_9)
2164 {
2165 rank *= 10;
2166 rank += data[idx++] - UNI_ASCII_0;
2167 }
2168 ++idx; // skip space after the rank
2169
2170 loop (r, rank)
2171 {
2172 ShapeItem s = 0;
2173 while (idx < data.size() &&
2174 data[idx] >= UNI_ASCII_0 &&
2175 data[idx] <= UNI_ASCII_9)
2176 {
2177 s *= 10;
2178 s += data[idx++] - UNI_ASCII_0;
2179 }
2180 shape.add_shape_item(s);
2181 ++idx; // skip space after shape[r]
2182 }
2183
2184 return idx;
2185 }
2186 //-----------------------------------------------------------------------------
2187 void
numeric_1TF(const UCS_string_vector & objects) const2188 Command::transfer_context::numeric_1TF(const UCS_string_vector & objects) const
2189 {
2190 UCS_string var_name;
2191 Shape shape;
2192 int idx = get_nrs(var_name, shape);
2193
2194 if (objects.size() && !objects.contains(var_name)) return;
2195
2196 Symbol * sym = 0;
2197 if (Avec::is_quad(var_name[0])) // system variable.
2198 {
2199 int len = 0;
2200 const Token t = Workspace::get_quad(var_name, len);
2201 if (t.get_ValueType() == TV_SYM) sym = t.get_sym_ptr();
2202 else Assert(0 && "Bad system variable");
2203 }
2204 else // user defined variable
2205 {
2206 sym = Workspace::lookup_symbol(var_name);
2207 Assert(sym);
2208 }
2209
2210 Log(LOG_command_IN)
2211 {
2212 CERR << endl << var_name << " rank " << shape.get_rank() << " IS '";
2213 loop(j, data.size() - idx) CERR << data[idx + j];
2214 CERR << "'" << endl;
2215 }
2216
2217 Token_string tos;
2218 {
2219 UCS_string data1(data, idx, data.size() - idx);
2220 Tokenizer tokenizer(PM_EXECUTE, LOC, false);
2221 if (tokenizer.tokenize(data1, tos) != E_NO_ERROR) return;
2222 }
2223
2224 if (tos.size() != size_t(shape.get_volume())) return;
2225
2226 Value_P val(shape, LOC);
2227 new (&val->get_ravel(0)) IntCell(0); // prototype
2228
2229 const ShapeItem ec = val->element_count();
2230 loop(e, ec)
2231 {
2232 const TokenTag tag = tos[e].get_tag();
2233 Cell * C = val->next_ravel();
2234 if (tag == TOK_INTEGER) new (C) IntCell(tos[e].get_int_val());
2235 else if (tag == TOK_REAL) new (C) FloatCell(tos[e].get_flt_val());
2236 else if (tag == TOK_COMPLEX) new (C)
2237 ComplexCell(tos[e].get_cpx_real(),
2238 tos[e].get_cpx_imag());
2239 else FIXME;
2240 }
2241
2242 val->check_value(LOC);
2243
2244 Assert(sym);
2245 sym->assign(val, false, LOC);
2246 }
2247 //-----------------------------------------------------------------------------
2248 void
chars_1TF(const UCS_string_vector & objects) const2249 Command::transfer_context::chars_1TF(const UCS_string_vector & objects) const
2250 {
2251 UCS_string var_name;
2252 Shape shape;
2253 int idx = get_nrs(var_name, shape);
2254
2255 if (objects.size() && !objects.contains(var_name)) return;
2256
2257 Symbol * sym = 0;
2258 if (Avec::is_quad(var_name[0])) // system variable.
2259 {
2260 int len = 0;
2261 const Token t = Workspace::get_quad(var_name, len);
2262 if (t.get_ValueType() == TV_SYM) sym = t.get_sym_ptr();
2263 else Assert(0 && "Bad system variable");
2264 }
2265 else // user defined variable
2266 {
2267 sym = Workspace::lookup_symbol(var_name);
2268 Assert(sym);
2269 }
2270
2271 Log(LOG_command_IN)
2272 {
2273 CERR << endl << var_name << " shape " << shape << " IS: '";
2274 loop(j, data.size() - idx) CERR << data[idx + j];
2275 CERR << "'" << endl;
2276 }
2277
2278 Value_P val(shape, LOC);
2279 const ShapeItem ec = val->element_count();
2280 new (&val->get_ravel(0)) CharCell(UNI_ASCII_SPACE); // prototype
2281
2282 ShapeItem padded = 0;
2283 loop(e, ec)
2284 {
2285 Unicode uni = UNI_ASCII_SPACE;
2286 if (e < (data.size() - idx)) uni = data[e + idx];
2287 else ++padded;
2288 new (&val->get_ravel(e)) CharCell(uni);
2289 }
2290
2291 if (padded)
2292 {
2293 CERR << "WARNING: ATF Record for " << var_name << " is broken ("
2294 << padded << " spaces added)" << endl;
2295 }
2296
2297 val->check_value(LOC);
2298
2299 Assert(sym);
2300 sym->assign(val, false, LOC);
2301 }
2302 //-----------------------------------------------------------------------------
2303 void
array_2TF(const UCS_string_vector & objects) const2304 Command::transfer_context::array_2TF(const UCS_string_vector & objects) const
2305 {
2306 // an Array in 2 ⎕TF format
2307 //
2308 UCS_string data1(&data[1], data.size() - 1);
2309 UCS_string var_or_fun;
2310
2311 // data1 is: VARNAME←data...
2312 //
2313 if (objects.size())
2314 {
2315 UCS_string var_name;
2316 loop(d, data1.size())
2317 {
2318 const Unicode uni = data1[d];
2319 if (uni == UNI_LEFT_ARROW) break;
2320 var_name.append(uni);
2321 }
2322
2323 if (!objects.contains(var_name)) return;
2324 }
2325
2326 var_or_fun = Quad_TF::tf2_inv(data1);
2327
2328 if (var_or_fun.size() == 0)
2329 {
2330 CERR << "ERROR: inverse 2 ⎕TF failed for '" << data1 << ";" << endl;
2331 }
2332 }
2333 //-----------------------------------------------------------------------------
2334 void
function_2TF(const UCS_string_vector & objects) const2335 Command::transfer_context::function_2TF(const UCS_string_vector & objects)const
2336 {
2337 int idx = 1;
2338 UCS_string fun_name;
2339
2340 /// chars 1...' ' are the function name
2341 while ((idx < data.size()) && (data[idx] != UNI_ASCII_SPACE))
2342 fun_name.append(data[idx++]);
2343 ++idx;
2344
2345 if (objects.size() && !objects.contains(fun_name)) return;
2346
2347 UCS_string statement;
2348 while (idx < data.size()) statement.append(data[idx++]);
2349 statement.append(UNI_ASCII_LF);
2350
2351 UCS_string fun_name1 = Quad_TF::tf2_inv(statement);
2352 if (fun_name1.size() == 0) // tf2_inv() failed
2353 {
2354 CERR << "inverse 2 ⎕TF failed for the following APL statement: "
2355 << endl << " " << statement << endl;
2356 return;
2357 }
2358
2359 Symbol * sym1 = Workspace::lookup_existing_symbol(fun_name1);
2360 Assert(sym1);
2361 Function * fun1 = sym1->get_function();
2362 Assert(fun1);
2363 fun1->set_creation_time(timestamp);
2364
2365 Log(LOG_command_IN)
2366 {
2367 const YMDhmsu ymdhmsu(timestamp);
2368 CERR << "FUNCTION '" << fun_name1 << "'" << endl
2369 << " created: " << ymdhmsu.day << "." << ymdhmsu.month
2370 << "." << ymdhmsu.year << " " << ymdhmsu.hour
2371 << ":" << ymdhmsu.minute << ":" << ymdhmsu.second
2372 << "." << ymdhmsu.micro << " (" << timestamp << ")" << endl;
2373 }
2374 }
2375 //-----------------------------------------------------------------------------
2376 void
add(const UTF8 * str,int len)2377 Command::transfer_context::add(const UTF8 * str, int len)
2378 {
2379
2380 #if 0
2381 // helper to print the uni_to_cp_map when given a cp_to_uni_map.
2382 //
2383 Avec::print_inverse_IBM_quad_AV();
2384 DOMAIN_ERROR;
2385 #endif
2386
2387 const Unicode * cp_to_uni_map = Avec::IBM_quad_AV();
2388 loop(l, len)
2389 {
2390 const UTF8 utf = str[l];
2391 switch(utf)
2392 {
2393 case '^': data.append(UNI_AND); break; // ~ → ∼
2394 case '*': data.append(UNI_STAR_OPERATOR); break; // * → ⋆
2395 case '~': data.append(UNI_TILDE_OPERATOR); break; // ~ → ∼
2396
2397 default: data.append(Unicode(cp_to_uni_map[utf]));
2398 }
2399 }
2400 }
2401 //-----------------------------------------------------------------------------
2402 bool
parse_from_to(UCS_string & from,UCS_string & to,const UCS_string & user_arg)2403 Command::parse_from_to(UCS_string & from, UCS_string & to,
2404 const UCS_string & user_arg)
2405 {
2406 // parse user_arg which is one of the following:
2407 //
2408 // 1. (empty)
2409 // 2. FROMTO
2410 // 3a. FROM -
2411 // 3b. - TO
2412 // 3c. FROM - TO
2413 //
2414 from.clear();
2415 to.clear();
2416
2417 int s = 0;
2418 bool got_minus = false;
2419
2420 // skip spaces before from
2421 //
2422 while (s < user_arg.size() && user_arg[s] <= ' ') ++s;
2423
2424 if (s == user_arg.size()) return false; // case 1.: OK
2425
2426 // copy left of - to from
2427 //
2428 while (s < user_arg.size() &&
2429 user_arg[s] > ' ' &&
2430 user_arg[s] != '-') from.append(user_arg[s++]);
2431
2432 // skip spaces after from
2433 //
2434 while (s < user_arg.size() && user_arg[s] <= ' ') ++s;
2435
2436 if (s < user_arg.size() && user_arg[s] == '-') { ++s; got_minus = true; }
2437
2438 // skip spaces before to
2439 //
2440 while (s < user_arg.size() && user_arg[s] <= ' ') ++s;
2441
2442 // copy right of - to from
2443 //
2444 while (s < user_arg.size() && user_arg[s] > ' ') to.append(user_arg[s++]);
2445
2446 // skip spaces after to
2447 //
2448 while (s < user_arg.size() && user_arg[s] <= ' ') ++s;
2449
2450 if (s < user_arg.size()) return true; // error: non-blank after to
2451
2452 if (!got_minus) to = from; // case 2.
2453
2454 if (from.size() == 0 && to.size() == 0) return true; // error: single -
2455
2456 // "increment" TO so that we can compare ITEM < TO
2457 //
2458 if (to.size()) to.back() = Unicode(to.back() + 1);
2459
2460 return false; // OK
2461 }
2462 //-----------------------------------------------------------------------------
2463 bool
is_lib_ref(const UCS_string & lib)2464 Command::is_lib_ref(const UCS_string & lib)
2465 {
2466 if (lib.size() == 1) // single char: lib number
2467 {
2468 if (Avec::is_digit(lib[0])) return true;
2469 }
2470
2471 if (lib[0] == UNI_ASCII_FULLSTOP) return true;
2472
2473 loop(l, lib.size())
2474 {
2475 const Unicode uni = lib[l];
2476 if (uni == UNI_ASCII_SLASH) return true;
2477 if (uni == UNI_ASCII_BACKSLASH) return true;
2478 }
2479
2480 return false;
2481 }
2482 //-----------------------------------------------------------------------------
2483