"Fossies" - the Fresh Open Source Software Archive

Member "free42-3.0.13a/common/core_commands7.cc" (18 Jun 2022, 61870 Bytes) of package /linux/misc/free42-3.0.13a.tar.gz:


As a special service "Fossies" has tried to format the requested source page into HTML format using (guessed) C and C++ source code syntax highlighting (style: standard) with prefixed line numbers and code folding option. Alternatively you can here view or download the uninterpreted source code file. For more information about "core_commands7.cc" see the Fossies "Dox" file reference documentation and the last Fossies "Diffs" side-by-side code changes report: 3.0.10_vs_3.0.11.

    1 /*****************************************************************************
    2  * Free42 -- an HP-42S calculator simulator
    3  * Copyright (C) 2004-2022  Thomas Okken
    4  *
    5  * This program is free software; you can redistribute it and/or modify
    6  * it under the terms of the GNU General Public License, version 2,
    7  * as published by the Free Software Foundation.
    8  *
    9  * This program is distributed in the hope that it will be useful,
   10  * but WITHOUT ANY WARRANTY; without even the implied warranty of
   11  * MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
   12  * GNU General Public License for more details.
   13  *
   14  * You should have received a copy of the GNU General Public License
   15  * along with this program; if not, see http://www.gnu.org/licenses/.
   16  *****************************************************************************/
   17 
   18 #include <stdlib.h>
   19 #include <stdio.h>
   20 #include <string.h>
   21 #include <stdarg.h>
   22 
   23 #include "core_commands1.h"
   24 #include "core_commands2.h"
   25 #include "core_commands7.h"
   26 #include "core_display.h"
   27 #include "core_globals.h"
   28 #include "core_helpers.h"
   29 #include "core_main.h"
   30 #include "core_sto_rcl.h"
   31 #include "core_variables.h"
   32 #include "shell.h"
   33 
   34 /////////////////////////////////////////////////////////////////
   35 ///// Accelerometer, Location Services, and Compass support /////
   36 /////////////////////////////////////////////////////////////////
   37 
   38 #if defined(ANDROID) || defined(IPHONE)
   39 
   40 int docmd_accel(arg_struct *arg) {
   41     double x, y, z;
   42     bool success = shell_get_acceleration(&x, &y, &z);
   43     if (!success)
   44         return ERR_NONEXISTENT;
   45     if (flags.f.big_stack)
   46         if (!ensure_stack_capacity(flags.f.stack_lift_disable ? 2 : 3))
   47             return ERR_INSUFFICIENT_MEMORY;
   48     vartype *new_x = new_real(x);
   49     vartype *new_y = new_real(y);
   50     vartype *new_z = new_real(z);
   51     if (new_x == NULL || new_y == NULL || new_z == NULL) {
   52         free_vartype(new_x);
   53         free_vartype(new_y);
   54         free_vartype(new_z);
   55         return ERR_INSUFFICIENT_MEMORY;
   56     }
   57     if (flags.f.big_stack) {
   58         if (flags.f.stack_lift_disable) {
   59             free_vartype(stack[sp]);
   60             sp += 2;
   61         } else {
   62             sp += 3;
   63         }
   64     } else {
   65         free_vartype(stack[REG_T]);
   66         free_vartype(stack[REG_Z]);
   67         if (flags.f.stack_lift_disable) {
   68             free_vartype(stack[REG_X]);
   69             stack[REG_T] = stack[REG_Y];
   70         } else {
   71             free_vartype(stack[REG_Y]);
   72             stack[REG_T] = stack[REG_X];
   73         }
   74     }
   75     stack[sp - 2] = new_z;
   76     stack[sp - 1] = new_y;
   77     stack[sp] = new_x;
   78     print_trace();
   79     return ERR_NONE;
   80 }
   81 
   82 int docmd_locat(arg_struct *arg) {
   83     double lat, lon, lat_lon_acc, elev, elev_acc;
   84     bool success = shell_get_location(&lat, &lon, &lat_lon_acc, &elev, &elev_acc);
   85     if (!success)
   86         return ERR_NONEXISTENT;
   87     if (flags.f.big_stack)
   88         if (!ensure_stack_capacity(flags.f.stack_lift_disable ? 3 : 4))
   89             return ERR_INSUFFICIENT_MEMORY;
   90     vartype *new_x = new_real(lat);
   91     vartype *new_y = new_real(lon);
   92     vartype *new_z = new_real(elev);
   93     vartype *new_t = new_realmatrix(1, 2);
   94     if (new_x == NULL || new_y == NULL || new_z == NULL || new_t == NULL) {
   95         free_vartype(new_x);
   96         free_vartype(new_y);
   97         free_vartype(new_z);
   98         free_vartype(new_t);
   99         return ERR_INSUFFICIENT_MEMORY;
  100     }
  101     vartype_realmatrix *rm = (vartype_realmatrix *) new_t;
  102     rm->array->data[0] = lat_lon_acc;
  103     rm->array->data[1] = elev_acc;
  104     if (flags.f.big_stack) {
  105         if (flags.f.stack_lift_disable) {
  106             free_vartype(stack[sp]);
  107             sp += 3;
  108         } else {
  109             sp += 4;
  110         }
  111     } else {
  112         for (int i = 0; i < 4; i++)
  113             free_vartype(stack[i]);
  114     }
  115     stack[sp - 3] = new_t;
  116     stack[sp - 2] = new_z;
  117     stack[sp - 1] = new_y;
  118     stack[sp] = new_x;
  119     print_trace();
  120     return ERR_NONE;
  121 }
  122 
  123 int docmd_heading(arg_struct *arg) {
  124     double mag_heading, true_heading, acc, x, y, z;
  125     bool success = shell_get_heading(&mag_heading, &true_heading, &acc, &x, &y, &z);
  126     if (!success)
  127         return ERR_NONEXISTENT;
  128     if (flags.f.big_stack)
  129         if (!ensure_stack_capacity(flags.f.stack_lift_disable ? 3 : 4))
  130             return ERR_INSUFFICIENT_MEMORY;
  131     vartype *new_x = new_real(mag_heading);
  132     vartype *new_y = new_real(true_heading);
  133     vartype *new_z = new_real(acc);
  134     vartype *new_t = new_realmatrix(1, 3);
  135     if (new_x == NULL || new_y == NULL || new_z == NULL || new_t == NULL) {
  136         free_vartype(new_x);
  137         free_vartype(new_y);
  138         free_vartype(new_z);
  139         free_vartype(new_t);
  140         return ERR_INSUFFICIENT_MEMORY;
  141     }
  142     vartype_realmatrix *rm = (vartype_realmatrix *) new_t;
  143     rm->array->data[0] = x;
  144     rm->array->data[1] = y;
  145     rm->array->data[2] = z;
  146     if (flags.f.big_stack) {
  147         if (flags.f.stack_lift_disable) {
  148             free_vartype(stack[sp]);
  149             sp += 3;
  150         } else {
  151             sp += 4;
  152         }
  153     } else {
  154         for (int i = 0; i < 4; i++)
  155             free_vartype(stack[i]);
  156     }
  157     stack[sp - 3] = new_t;
  158     stack[sp - 2] = new_z;
  159     stack[sp - 1] = new_y;
  160     stack[sp] = new_x;
  161     print_trace();
  162     return ERR_NONE;
  163 }
  164 
  165 #else
  166 
  167 int docmd_accel(arg_struct *arg) {
  168     return ERR_NONEXISTENT;
  169 }
  170 
  171 int docmd_locat(arg_struct *arg) {
  172     return ERR_NONEXISTENT;
  173 }
  174 
  175 int docmd_heading(arg_struct *arg) {
  176     return ERR_NONEXISTENT;
  177 }
  178 
  179 #endif
  180 
  181 /////////////////////////////////////////////////
  182 ///// HP-41 Time Module & CX Time emulation /////
  183 /////////////////////////////////////////////////
  184 
  185 static int date2comps(phloat x, int4 *yy, int4 *mm, int4 *dd) {
  186     int4 y, m, d;
  187 #ifdef BCD_MATH
  188     if (flags.f.ymd) {
  189         y = to_int4(floor(x));
  190         m = to_int4(floor((x - y) * 100));
  191         d = to_int4(x * 10000) % 100;
  192     } else {
  193         m = to_int4(floor(x));
  194         d = to_int4(floor((x - m) * 100));
  195         y = to_int4(x * 1000000) % 10000;
  196     }
  197 #else
  198     if (flags.f.ymd) {
  199         y = to_int4(floor(x));
  200         int4 r = (int4) floor((x - y) * 100000000 + 0.5);
  201         r /= 10000;
  202         m = r / 100;
  203         d = r % 100;
  204     } else {
  205         m = to_int4(floor(x));
  206         int4 r = (int4) floor((x - m) * 100000000 + 0.5);
  207         r /= 100;
  208         d = r / 10000;
  209         y = r % 10000;
  210     }
  211 #endif
  212 
  213     if (!flags.f.ymd && flags.f.dmy) {
  214         int4 t = m;
  215         m = d;
  216         d = t;
  217     }
  218 
  219     if (y < 1582 || y > 4320 || m < 1 || m > 12 || d < 1 || d > 31)
  220         return ERR_INVALID_DATA;
  221     if ((m == 4 || m == 6 || m == 9 || m == 11) && d == 31)
  222         return ERR_INVALID_DATA;
  223     if (m == 2 && d > ((y % 4 == 0 && (y % 100 != 0 || y % 400 == 0)) ? 29 : 28))
  224         return ERR_INVALID_DATA;
  225     if (y == 1582 && (m < 10 || m == 10 && d < 15)
  226             || y == 4320 && (m > 9 || m == 9 && d > 10))
  227         return ERR_INVALID_DATA;
  228 
  229     *yy = y;
  230     *mm = m;
  231     *dd = d;
  232     return ERR_NONE;
  233 }
  234 
  235 static phloat comps2date(int4 y, int4 m, int4 d) {
  236     if (flags.f.ymd)
  237         return phloat(y * 10000 + m * 100 + d) / 10000;
  238     if (flags.f.dmy) {
  239         int4 t = m;
  240         m = d;
  241         d = t;
  242     }
  243     return phloat(m * 1000000 + d * 10000 + y) / 1000000;
  244 }
  245 
  246 /* Gregorian Date <-> Day Number conversion functions
  247  * Algorithm due to Henry F. Fliegel and Thomas C. Van Flandern,
  248  * Communications of the ACM, Vol. 11, No. 10 (October, 1968).
  249  */
  250 static int greg2jd(int4 y, int4 m, int4 d, int4 *jd) {
  251     *jd = ( 1461 * ( y + 4800 + ( m - 14 ) / 12 ) ) / 4 +
  252           ( 367 * ( m - 2 - 12 * ( ( m - 14 ) / 12 ) ) ) / 12 -
  253           ( 3 * ( ( y + 4900 + ( m - 14 ) / 12 ) / 100 ) ) / 4 +
  254           d - 32075;
  255     return ERR_NONE;
  256 }
  257 
  258 static int jd2greg(int4 jd, int4 *y, int4 *m, int4 *d) {
  259     if (jd < 2299161 || jd > 3299160)
  260         return ERR_OUT_OF_RANGE;
  261     int4 l = jd + 68569;
  262     int4 n = ( 4 * l ) / 146097;
  263     l = l - ( 146097 * n + 3 ) / 4;
  264     int4 i = ( 4000 * ( l + 1 ) ) / 1461001;
  265     l = l - ( 1461 * i ) / 4 + 31;
  266     int4 j = ( 80 * l ) / 2447;
  267     *d = l - ( 2447 * j ) / 80;
  268     l = j / 11;
  269     *m = j + 2 - ( 12 * l );
  270     *y = 100 * ( n - 49 ) + i + l;
  271     return ERR_NONE;
  272 }
  273 
  274 
  275 int docmd_adate(arg_struct *arg) {
  276     phloat x = ((vartype_real *) stack[sp])->x;
  277     if (x < 0)
  278         x = -x;
  279 
  280     int digits;
  281     if (flags.f.fix_or_all && flags.f.eng_or_all)
  282         digits = 11;
  283     else {
  284         digits = 0;
  285         if (flags.f.digits_bit3)
  286             digits += 8;
  287         if (flags.f.digits_bit2)
  288             digits += 4;
  289         if (flags.f.digits_bit1)
  290             digits += 2;
  291         if (flags.f.digits_bit0)
  292             digits += 1;
  293     }
  294 
  295     char buf[10];
  296     int bufptr = 0;
  297 
  298     if (flags.f.ymd) {
  299         if (x >= 10000)
  300             return ERR_INVALID_DATA;
  301 
  302         int4 y = to_int4(floor(x));
  303 #ifdef BCD_MATH
  304         int4 m = to_int4(floor((x - y) * 100));
  305         int4 d = to_int4(x * 10000) % 100;
  306 #else
  307         int4 r = (int4) floor((x - y) * 100000000 + 0.5);
  308         r /= 10000;
  309         int4 m = r / 100;
  310         int4 d = r % 100;
  311 #endif
  312         bufptr += int2string(y, buf + bufptr, 10 - bufptr);
  313         if (digits > 0) {
  314             char2buf(buf, 10, &bufptr, '-');
  315             if (m < 10)
  316                 char2buf(buf, 10, &bufptr, '0');
  317             bufptr += int2string(m, buf + bufptr, 10 - bufptr);
  318             if (digits > 2) {
  319                 char2buf(buf, 10, &bufptr, '-');
  320                 if (d < 10)
  321                     char2buf(buf, 10, &bufptr, '0');
  322                 bufptr += int2string(d, buf + bufptr, 10 - bufptr);
  323             }
  324         }
  325     } else {
  326         if (x >= 100)
  327             return ERR_INVALID_DATA;
  328 
  329         int4 m = to_int4(floor(x));
  330 #ifdef BCD_MATH
  331         int4 d = to_int4(floor((x - m) * 100));
  332         int4 y = to_int4(x * 1000000) % 10000;
  333 #else
  334         int4 r = (int4) floor((x - m) * 100000000 + 0.5);
  335         r /= 100;
  336         int4 d = r / 10000;
  337         int4 y = r % 10000;
  338 #endif
  339         int c = y / 100;
  340         y %= 100;
  341 
  342         if (m < 10)
  343             char2buf(buf, 10, &bufptr, '0');
  344         bufptr += int2string(m, buf + bufptr, 10 - bufptr);
  345         if (digits > 0) {
  346             char2buf(buf, 10, &bufptr, flags.f.dmy ? '.' : '/');
  347             if (d < 10)
  348                 char2buf(buf, 10, &bufptr, '0');
  349             bufptr += int2string(d, buf + bufptr, 10 - bufptr);
  350             if (digits > 2) {
  351                 char2buf(buf, 10, &bufptr, flags.f.dmy ? '.' : '/');
  352                 if (digits > 4) {
  353                     if (c < 10)
  354                         char2buf(buf, 10, &bufptr, '0');
  355                     bufptr += int2string(c, buf + bufptr, 10 - bufptr);
  356                 }
  357                 if (y < 10)
  358                     char2buf(buf, 10, &bufptr, '0');
  359                 bufptr += int2string(y, buf + bufptr, 10 - bufptr);
  360             }
  361         }
  362     }
  363 
  364     append_alpha_string(buf, bufptr, 0);
  365     return ERR_NONE;
  366 }
  367 
  368 int docmd_atime(arg_struct *arg) {
  369     phloat x = ((vartype_real *) stack[sp])->x;
  370     bool neg = x < 0;
  371     if (neg)
  372         x = -x;
  373     if (x >= 100)
  374         return ERR_INVALID_DATA;
  375     int h = to_int(floor(x));
  376     if (h == 0)
  377         neg = false;
  378     int4 ms = to_int4(floor((x - floor(x)) * 1000000));
  379     int m = (int) (ms / 10000);
  380     int s = (int) (ms / 100 % 100);
  381     int cs = (int) (ms % 100);
  382     bool am = false;
  383     bool pm = false;
  384 
  385     if (mode_time_clk24) {
  386         if (neg && h >= 1 && h <= 11)
  387             h += 12;
  388     } else if (h < 24) {
  389         if (!neg && h < 12)
  390             am = true;
  391         else
  392             pm = true;
  393         if (h == 0)
  394             h = 12;
  395         else if (h > 12)
  396             h -= 12;
  397     }
  398 
  399     int digits;
  400     if (flags.f.fix_or_all && flags.f.eng_or_all)
  401         digits = 11;
  402     else {
  403         digits = 0;
  404         if (flags.f.digits_bit3)
  405             digits += 8;
  406         if (flags.f.digits_bit2)
  407             digits += 4;
  408         if (flags.f.digits_bit1)
  409             digits += 2;
  410         if (flags.f.digits_bit0)
  411             digits += 1;
  412     }
  413 
  414     char buf[14];
  415     int bufptr = 0;
  416     if (h < 10)
  417         char2buf(buf, 14, &bufptr, mode_time_clk24 ? '0' : ' ');
  418     bufptr += int2string(h, buf + bufptr, 14 - bufptr);
  419     if (digits > 0) {
  420         char2buf(buf, 14, &bufptr, ':');
  421         if (m < 10)
  422             char2buf(buf, 14, &bufptr, '0');
  423         bufptr += int2string(m, buf + bufptr, 14 - bufptr);
  424         if (digits > 2) {
  425             char2buf(buf, 14, &bufptr, ':');
  426             if (s < 10)
  427                 char2buf(buf, 14, &bufptr, '0');
  428             bufptr += int2string(s, buf + bufptr, 14 - bufptr);
  429             if (digits > 4) {
  430                 char2buf(buf, 14, &bufptr, '.');
  431                 if (cs < 10)
  432                     char2buf(buf, 14, &bufptr, '0');
  433                 bufptr += int2string(cs, buf + bufptr, 14 - bufptr);
  434             }
  435         }
  436     }
  437     if (am)
  438         string2buf(buf, 14, &bufptr, " AM", 3);
  439     else if (pm)
  440         string2buf(buf, 14, &bufptr, " PM", 3);
  441     append_alpha_string(buf, bufptr, 0);
  442 
  443     return ERR_NONE;
  444 }
  445 
  446 int docmd_atime24(arg_struct *arg) {
  447     bool saved_clk24 = mode_time_clk24;
  448     mode_time_clk24 = true;
  449     int res = docmd_atime(arg);
  450     mode_time_clk24 = saved_clk24;
  451     return res;
  452 }
  453 
  454 int docmd_clk12(arg_struct *arg) {
  455     mode_time_clk24 = false;
  456     return ERR_NONE;
  457 }
  458 
  459 int docmd_clk24(arg_struct *arg) {
  460     mode_time_clk24 = true;
  461     return ERR_NONE;
  462 }
  463 
  464 static char weekdaynames[] = "SUNMONTUEWEDTHUFRISAT";
  465 
  466 int docmd_date(arg_struct *arg) {
  467     uint4 date;
  468     int weekday;
  469     shell_get_time_date(NULL, &date, &weekday);
  470     int y = date / 10000;
  471     int m = date / 100 % 100;
  472     int d = date % 100;
  473     if (flags.f.ymd)
  474         date = y * 10000L + m * 100 + d;
  475     else if (flags.f.dmy)
  476         date = y + m * 10000L + d * 1000000;
  477     else
  478         date = y + m * 1000000 + d * 10000L;
  479     vartype *new_x = new_real((int4) date);
  480     if (new_x == NULL)
  481         return ERR_INSUFFICIENT_MEMORY;
  482     ((vartype_real *) new_x)->x /= flags.f.ymd ? 10000 : 1000000;
  483     if (!program_running()) {
  484         /* Note: I'm not completely faithful to the HP-41 here. It formats the
  485          * date as "14.03.2010 SUN" in DMY mode, and as "03/14/2010:SU" in MDY
  486          * mode. I mimic the former, but the latter I changed to
  487          * "03/14/2010 SUN"; the MDY display format used on the HP-41 is the
  488          * way it is because that was all they could fit in its 12-character
  489          * display. (Note that the periods in the DMY format and the colon in
  490          * the MDY format don't take up a character position on the HP-41.)
  491          */
  492         char buf[22];
  493         int bufptr = 0;
  494         if (flags.f.ymd) {
  495             bufptr += int2string(y, buf + bufptr, 22 - bufptr);
  496             char2buf(buf, 22, &bufptr, '-');
  497             if (m < 10)
  498                 char2buf(buf, 22, &bufptr, '0');
  499             bufptr += int2string(m, buf + bufptr, 22 - bufptr);
  500             char2buf(buf, 22, &bufptr, '-');
  501             if (d < 10)
  502                 char2buf(buf, 22, &bufptr, '0');
  503             bufptr += int2string(d, buf + bufptr, 22 - bufptr);
  504         } else {
  505             int n = flags.f.dmy ? d : m;
  506             if (n < 10)
  507                 char2buf(buf, 22, &bufptr, '0');
  508             bufptr += int2string(n, buf + bufptr, 22 - bufptr);
  509             char2buf(buf, 22, &bufptr, flags.f.dmy ? '.' : '/');
  510             n = flags.f.dmy ? m : d;
  511             if (n < 10)
  512                 char2buf(buf, 22, &bufptr, '0');
  513             bufptr += int2string(n, buf + bufptr, 22 - bufptr);
  514             char2buf(buf, 22, &bufptr, flags.f.dmy ? '.' : '/');
  515             bufptr += int2string(y, buf + bufptr, 22 - bufptr);
  516         }
  517         char2buf(buf, 22, &bufptr, ' ');
  518         string2buf(buf, 22, &bufptr, weekdaynames + weekday * 3, 3);
  519         clear_row(0);
  520         draw_string(0, 0, buf, bufptr);
  521         flush_display();
  522         flags.f.message = 1;
  523         flags.f.two_line_message = 0;
  524         if (flags.f.trace_print && flags.f.printer_exists)
  525             print_text(buf, bufptr, true);
  526     }
  527     return recall_result(new_x);
  528 }
  529 
  530 int docmd_date_plus(arg_struct *arg) {
  531     phloat date = ((vartype_real *) stack[sp - 1])->x;
  532     if (date < 0 || date > (flags.f.ymd ? 10000 : 100))
  533         return ERR_INVALID_DATA;
  534     phloat days = ((vartype_real *) stack[sp])->x;
  535     if (days < -1000000 || days > 1000000)
  536         return ERR_OUT_OF_RANGE;
  537 
  538     int4 y, m, d, jd;
  539     int err = date2comps(date, &y, &m, &d);
  540     if (err != ERR_NONE)
  541         return err;
  542     err = greg2jd(y, m, d, &jd);
  543     if (err != ERR_NONE)
  544         return err;
  545     jd += to_int4(days < 0 ? -floor(-days) : floor(days));
  546     err = jd2greg(jd, &y, &m, &d);
  547     if (err != ERR_NONE)
  548         return err;
  549     date = comps2date(y, m, d);
  550 
  551     vartype *new_x = new_real(date);
  552     if (new_x == NULL)
  553         return ERR_INSUFFICIENT_MEMORY;
  554     return binary_result(new_x);
  555 }
  556 
  557 int docmd_ddays(arg_struct *arg) {
  558     phloat date1 = ((vartype_real *) stack[sp - 1])->x;
  559     if (date1 < 0 || date1 > (flags.f.ymd ? 10000 : 100))
  560         return ERR_INVALID_DATA;
  561     phloat date2 = ((vartype_real *) stack[sp])->x;
  562     if (date2 < 0 || date2 > (flags.f.ymd ? 10000 : 100))
  563         return ERR_INVALID_DATA;
  564     int4 y, m, d, jd1, jd2;
  565     int err = date2comps(date1, &y, &m, &d);
  566     if (err != ERR_NONE)
  567         return err;
  568     err = greg2jd(y, m, d, &jd1);
  569     if (err != ERR_NONE)
  570         return err;
  571     err = date2comps(date2, &y, &m, &d);
  572     if (err != ERR_NONE)
  573         return err;
  574     err = greg2jd(y, m, d, &jd2);
  575     if (err != ERR_NONE)
  576         return err;
  577 
  578     vartype *new_x = new_real(jd2 - jd1);
  579     if (new_x == NULL)
  580         return ERR_INSUFFICIENT_MEMORY;
  581     return binary_result(new_x);
  582 }
  583 
  584 int docmd_dmy(arg_struct *arg) {
  585     flags.f.dmy = true;
  586     flags.f.ymd = false;
  587     return ERR_NONE;
  588 }
  589 
  590 int docmd_dow(arg_struct *arg) {
  591     phloat x = ((vartype_real *) stack[sp])->x;
  592     if (x < 0 || x > (flags.f.ymd ? 10000 : 100))
  593         return ERR_INVALID_DATA;
  594 
  595     int4 y, m, d, jd;
  596     int err = date2comps(x, &y, &m, &d);
  597     if (err != ERR_NONE)
  598         return err;
  599     err = greg2jd(y, m, d, &jd);
  600     if (err != ERR_NONE)
  601         return err;
  602     jd = (jd + 1) % 7;
  603 
  604     vartype *new_x = new_real(jd);
  605     if (new_x == NULL)
  606         return ERR_INSUFFICIENT_MEMORY;
  607 
  608     if (!program_running()) {
  609         clear_row(0);
  610         draw_string(0, 0, weekdaynames + jd * 3, 3);
  611         flush_display();
  612         flags.f.message = 1;
  613         flags.f.two_line_message = 0;
  614         if (flags.f.trace_print && flags.f.printer_exists)
  615             print_text(weekdaynames + jd * 3, 3, true);
  616     }
  617 
  618     unary_result(new_x);
  619     return ERR_NONE;
  620 }
  621 
  622 int docmd_mdy(arg_struct *arg) {
  623     flags.f.dmy = false;
  624     flags.f.ymd = false;
  625     return ERR_NONE;
  626 }
  627 
  628 int docmd_time(arg_struct *arg) {
  629     uint4 time;
  630     shell_get_time_date(&time, NULL, NULL);
  631     vartype *new_x = new_real((int4) time);
  632     if (new_x == NULL)
  633         return ERR_INSUFFICIENT_MEMORY;
  634     ((vartype_real *) new_x)->x /= 1000000;
  635     if (!program_running()) {
  636         int h = time / 1000000;
  637         bool am;
  638         if (!mode_time_clk24) {
  639             am = h < 12;
  640             h = h % 12;
  641             if (h == 0)
  642                 h = 12;
  643         }
  644         int m = time / 10000 % 100;
  645         int s = time / 100 % 100;
  646         char buf[22];
  647         int bufptr = 0;
  648         if (h < 10)
  649             char2buf(buf, 22, &bufptr, ' ');
  650         bufptr += int2string(h, buf + bufptr, 22 - bufptr);
  651         char2buf(buf, 22, &bufptr, ':');
  652         if (m < 10)
  653             char2buf(buf, 22, &bufptr, '0');
  654         bufptr += int2string(m, buf + bufptr, 22 - bufptr);
  655         char2buf(buf, 22, &bufptr, ':');
  656         if (s < 10)
  657             char2buf(buf, 22, &bufptr, '0');
  658         bufptr += int2string(s, buf + bufptr, 22 - bufptr);
  659         if (!mode_time_clk24) {
  660             char2buf(buf, 22, &bufptr, ' ');
  661             char2buf(buf, 22, &bufptr, am ? 'A' : 'P');
  662             char2buf(buf, 22, &bufptr, 'M');
  663         }
  664         clear_row(0);
  665         draw_string(0, 0, buf, bufptr);
  666         flush_display();
  667         flags.f.message = 1;
  668         flags.f.two_line_message = 0;
  669         if (flags.f.trace_print && flags.f.printer_exists)
  670             print_text(buf, bufptr, true);
  671     }
  672     return recall_result(new_x);
  673 }
  674 
  675 // The YMD function is not an original Time Module function, and in Free42,
  676 // it is grouped with the "Programming" extension, but logically, of course,
  677 // it belongs here. Also, most of the YMD implementation consists of
  678 // modifications to Time Module functions, so in that sense, most of it is
  679 // here anyway.
  680 
  681 int docmd_ymd(arg_struct *arg) {
  682     flags.f.dmy = false;
  683     flags.f.ymd = true;
  684     return ERR_NONE;
  685 }
  686 
  687 int docmd_getkey1(arg_struct *arg) {
  688     mode_getkey = true;
  689     mode_getkey1 = true;
  690     mode_disable_stack_lift = flags.f.stack_lift_disable;
  691     return ERR_NONE;
  692 }
  693 
  694 ////////////////////////////////////////////////////////////////
  695 ///// Intel Decimal Floating-Point Math Library: self-test /////
  696 ////////////////////////////////////////////////////////////////
  697 
  698 #ifdef FREE42_FPTEST
  699 
  700 static int tests_lineno;
  701 extern const char *readtest_lines[];
  702 
  703 extern "C" {
  704     int readtest_main(int argc, char *argv[]);
  705 
  706     int tests_eof() {
  707         return readtest_lines[tests_lineno] == NULL;
  708     }
  709 
  710     void tests_readline(char *buf, int bufsize) {
  711         const char *line = readtest_lines[tests_lineno++];
  712         strncpy(buf, line, bufsize - 1);
  713         buf[bufsize - 1] = 0;
  714     }
  715 
  716     int testlogprintf(const char *fmt, ...) {
  717         int c;
  718         va_list ap;
  719         char text[1024];
  720         va_start(ap, fmt);
  721         c = vsprintf(text, fmt, ap);
  722         shell_log(text);
  723         va_end(ap);
  724         return c;
  725     }
  726 }
  727 
  728 int docmd_fptest(arg_struct *arg) {
  729     tests_lineno = 0;
  730     char *argv[] = { (char *) "readtest", NULL };
  731     int result = readtest_main(1, argv);
  732     vartype *v = new_real(result);
  733     if (v == NULL)
  734         return ERR_INSUFFICIENT_MEMORY;
  735     return recall_result(v);
  736 }
  737 
  738 #else
  739 
  740 int docmd_fptest(arg_struct *arg) {
  741     return ERR_NONEXISTENT;
  742 }
  743 
  744 #endif
  745 
  746 /////////////////////////////////
  747 ///// Programming Extension /////
  748 /////////////////////////////////
  749 
  750 int docmd_lsto(arg_struct *arg) {
  751     int err;
  752     if (arg->type == ARGTYPE_IND_NUM
  753             || arg->type == ARGTYPE_IND_STK
  754             || arg->type == ARGTYPE_IND_STR) {
  755         err = resolve_ind_arg(arg);
  756         if (err != ERR_NONE)
  757             return err;
  758     }
  759     if (arg->type != ARGTYPE_STR)
  760         return ERR_INVALID_TYPE;
  761     /* Only allow matrices to be stored in "REGS" */
  762     if (string_equals(arg->val.text, arg->length, "REGS", 4)
  763             && stack[sp]->type != TYPE_REALMATRIX
  764             && stack[sp]->type != TYPE_COMPLEXMATRIX)
  765         return ERR_RESTRICTED_OPERATION;
  766     /* When EDITN is active, don't allow the matrix being
  767      * edited to be overwritten. */
  768     if (matedit_mode == 3 && string_equals(arg->val.text,
  769                 arg->length, matedit_name, matedit_length))
  770         return ERR_RESTRICTED_OPERATION;
  771     vartype *newval = dup_vartype(stack[sp]);
  772     if (newval == NULL)
  773         return ERR_INSUFFICIENT_MEMORY;
  774     return store_var(arg->val.text, arg->length, newval, true);
  775 }
  776 
  777 int docmd_lasto(arg_struct *arg) {
  778     int temp_alpha_length = reg_alpha_length;
  779     if (reg_alpha_length > 6)
  780         reg_alpha_length = 6;
  781     int err = docmd_lxasto(arg);
  782     reg_alpha_length = temp_alpha_length;
  783     return err;
  784 }
  785 
  786 int docmd_lxasto(arg_struct *arg) {
  787     /* This relates to LSTO the same way ASTO relates to STO. */
  788     vartype *s = new_string(reg_alpha, reg_alpha_length);
  789     if (s == NULL)
  790         return ERR_INSUFFICIENT_MEMORY;
  791     int err;
  792     if (arg->type == ARGTYPE_IND_STK && arg->val.stk == 'X') {
  793         // Special case for LASTO IND ST X
  794         err = resolve_ind_arg(arg);
  795         if (err != ERR_NONE) {
  796             free_vartype(s);
  797             return err;
  798         }
  799     }
  800     vartype *saved_x;
  801     if (sp == -1) {
  802         saved_x = NULL;
  803         sp = 0;
  804     } else {
  805         saved_x = stack[sp];
  806     }
  807     stack[sp] = s;
  808     err = docmd_lsto(arg);
  809     free_vartype(s);
  810     if (saved_x == NULL)
  811         sp = -1;
  812     else
  813         stack[sp] = saved_x;
  814     return err;
  815 }
  816 
  817 int docmd_wsize(arg_struct *arg) {
  818     phloat x = ((vartype_real *) stack[sp])->x;
  819 #ifdef BCD_MATH
  820     if (x >= 65 || x < 1)
  821 #else
  822     if (x >= 54 || x < 1)
  823 #endif
  824         return ERR_INVALID_DATA;
  825     mode_wsize = to_int(x);
  826     print_trace();
  827     return ERR_NONE;
  828 }
  829 
  830 int docmd_wsize_t(arg_struct *arg) {
  831     vartype *new_x = new_real(effective_wsize());
  832     if (new_x == NULL)
  833         return ERR_INSUFFICIENT_MEMORY;
  834     return recall_result(new_x);
  835 }
  836 
  837 int docmd_bsigned(arg_struct *arg) {
  838     flags.f.base_signed = !flags.f.base_signed;
  839     return ERR_NONE;
  840 }
  841 
  842 int docmd_bwrap(arg_struct *arg) {
  843     flags.f.base_wrap = !flags.f.base_wrap;
  844     return ERR_NONE;
  845 }
  846 
  847 int docmd_breset(arg_struct *arg) {
  848     mode_wsize = 36;
  849     flags.f.base_signed = 1;
  850     flags.f.base_wrap = 0;
  851     return ERR_NONE;
  852 }
  853 
  854 ////////////////////////////////////////////////////////
  855 ///// The NOP that's been missing since the HP-41C /////
  856 ////////////////////////////////////////////////////////
  857 
  858 int docmd_nop(arg_struct *arg) {
  859     return ERR_NONE;
  860 }
  861 
  862 //////////////////////////////
  863 ///// Fused Multiply-Add /////
  864 //////////////////////////////
  865 
  866 int docmd_fma(arg_struct *arg) {
  867     phloat x = ((vartype_real *) stack[sp])->x;
  868     phloat y = ((vartype_real *) stack[sp - 1])->x;
  869     phloat z = ((vartype_real *) stack[sp - 2])->x;
  870     phloat r = fma(z, y, x);
  871     int inf = p_isinf(r);
  872     if (inf != 0) {
  873         if (flags.f.range_error_ignore)
  874             r = inf == 1 ? POS_HUGE_PHLOAT : NEG_HUGE_PHLOAT;
  875         else
  876             return ERR_OUT_OF_RANGE;
  877     }
  878     vartype *res = new_real(r);
  879     if (res == NULL)
  880         return ERR_INSUFFICIENT_MEMORY;
  881     return ternary_result(res);
  882 }
  883 
  884 int docmd_func(arg_struct *arg) {
  885     return push_func_state(arg->val.num);
  886 }
  887 
  888 int docmd_errmsg(arg_struct *arg) {
  889     vartype *v;
  890     if (lasterr != -1)
  891         v = new_string(errors[lasterr].text, errors[lasterr].length);
  892     else
  893         v = new_string(lasterr_text, lasterr_length);
  894     if (v == NULL)
  895         return ERR_INSUFFICIENT_MEMORY;
  896     return recall_result(v);
  897 }
  898 
  899 int docmd_errno(arg_struct *arg) {
  900     vartype *v;
  901     if (lasterr != -1)
  902         v = new_real(lasterr);
  903     else
  904         v = new_string(lasterr_text, lasterr_length);
  905     if (v == NULL)
  906         return ERR_INSUFFICIENT_MEMORY;
  907     return recall_result(v);
  908 }
  909 
  910 int docmd_rtnyes(arg_struct *arg) {
  911     if (!program_running())
  912         return ERR_RESTRICTED_OPERATION;
  913     int err = pop_func_state(false);
  914     if (err != ERR_NONE)
  915         return err;
  916     return rtn(ERR_YES);
  917 }
  918 
  919 int docmd_rtnno(arg_struct *arg) {
  920     if (!program_running())
  921         return ERR_RESTRICTED_OPERATION;
  922     int err = pop_func_state(false);
  923     if (err != ERR_NONE)
  924         return err;
  925     return rtn(ERR_NO);
  926 }
  927 
  928 int docmd_rtnerr(arg_struct *arg) {
  929     if (!program_running())
  930         return ERR_RESTRICTED_OPERATION;
  931     int err;
  932     int len;
  933     if (arg->type == ARGTYPE_IND_NUM
  934             || arg->type == ARGTYPE_IND_STK
  935             || arg->type == ARGTYPE_IND_STR) {
  936         len = 22;
  937         err = resolve_ind_arg(arg, lasterr_text, &len);
  938         if (err != ERR_NONE)
  939             return err;
  940     }
  941     if (arg->type == ARGTYPE_STR) {
  942         lasterr_length = len;
  943         err = -1;
  944     } else if (arg->type == ARGTYPE_NUM) {
  945         err = arg->val.num;
  946         if (err > RTNERR_MAX)
  947             return ERR_INVALID_DATA;
  948     } else {
  949         return ERR_INTERNAL_ERROR;
  950     }
  951     int err2 = pop_func_state(true);
  952     if (err2 != ERR_NONE)
  953         return err2;
  954     if (err != ERR_NONE && flags.f.error_ignore) {
  955         flags.f.error_ignore = 0;
  956         lasterr = err;
  957         err = ERR_NONE;
  958     }
  959     if (err != ERR_NONE)
  960         return rtn_with_error(err);
  961     else
  962         return rtn(ERR_NONE);
  963 }
  964 
  965 int docmd_strace(arg_struct *arg) {
  966     flags.f.trace_print = 1;
  967     flags.f.normal_print = 1;
  968     return ERR_NONE;
  969 }
  970 
  971 int docmd_varmnu1(arg_struct *arg) {
  972     int err = docmd_varmenu(arg);
  973     if (err == ERR_NONE) {
  974         mode_varmenu = true;
  975         varmenu_role = program_running() ? 3 : 0;
  976     }
  977     return err;
  978 }
  979 
  980 int docmd_x2line(arg_struct *arg) {
  981     return x2line();
  982 }
  983 
  984 int docmd_a2line(arg_struct *arg) {
  985     return a2line(false);
  986 }
  987 
  988 int docmd_a2pline(arg_struct *arg) {
  989     return a2line(true);
  990 }
  991 
  992 int docmd_rcomplx(arg_struct *arg) {
  993     bool p = flags.f.polar;
  994     flags.f.polar = 0;
  995     int err = docmd_complex(arg);
  996     flags.f.polar = p;
  997     return err;
  998 }
  999 
 1000 int docmd_pcomplx(arg_struct *arg) {
 1001     bool p = flags.f.polar;
 1002     flags.f.polar = 1;
 1003     int err = docmd_complex(arg);
 1004     flags.f.polar = p;
 1005     return err;
 1006 }
 1007 
 1008 int docmd_caps(arg_struct *arg) {
 1009     mode_menu_caps = true;
 1010     return ERR_NONE;
 1011 }
 1012 
 1013 int docmd_mixed(arg_struct *arg) {
 1014     mode_menu_caps = false;
 1015     return ERR_NONE;
 1016 }
 1017 
 1018 int docmd_skip(arg_struct *arg) {
 1019     return ERR_NO;
 1020 }
 1021 
 1022 int docmd_cpxmat_t(arg_struct *arg) {
 1023     return stack[sp]->type == TYPE_COMPLEXMATRIX ? ERR_YES : ERR_NO;
 1024 }
 1025 
 1026 int docmd_type_t(arg_struct *arg) {
 1027     vartype *v = new_real(stack[sp]->type);
 1028     if (v == NULL)
 1029         return ERR_INSUFFICIENT_MEMORY;
 1030     unary_result(v);
 1031     return ERR_NONE;
 1032 }
 1033 
 1034 /////////////////////
 1035 ///// Big Stack /////
 1036 /////////////////////
 1037 
 1038 int docmd_4stk(arg_struct *arg) {
 1039     if (!flags.f.big_stack)
 1040         return ERR_NONE;
 1041     // Should be safe to assume the stack always has capacity >= 4
 1042     if (sp < 3) {
 1043         int off = 3 - sp;
 1044         memmove(stack + off, stack, (sp + 1) * sizeof(vartype *));
 1045         for (int i = 0; i < off; i++) {
 1046             stack[i] = new_real(0);
 1047             if (stack[i] == NULL) {
 1048                 for (int j = 0; j < i; j++)
 1049                     free_vartype(stack[j]);
 1050                 memmove(stack, stack + off, (sp + 1) * sizeof(vartype *));
 1051                 return ERR_INSUFFICIENT_MEMORY;
 1052             }
 1053         }
 1054     } else if (sp > 3) {
 1055         int off = sp - 3;
 1056         for (int i = 0; i < off; i++)
 1057             free_vartype(stack[i]);
 1058         memmove(stack, stack + off, 4 * sizeof(vartype *));
 1059     }
 1060     sp = 3;
 1061     flags.f.big_stack = 0;
 1062     if (arg != NULL)
 1063         shrink_stack();
 1064     return ERR_NONE;
 1065 }
 1066 
 1067 int docmd_l4stk(arg_struct *arg) {
 1068     if (!program_running())
 1069         return ERR_RESTRICTED_OPERATION;
 1070     return push_stack_state(false);
 1071 }
 1072 
 1073 int docmd_nstk(arg_struct *arg) {
 1074     if (!core_settings.allow_big_stack)
 1075         return ERR_BIG_STACK_DISABLED;
 1076     flags.f.big_stack = 1;
 1077     return ERR_NONE;
 1078 }
 1079 
 1080 int docmd_lnstk(arg_struct *arg) {
 1081     if (!core_settings.allow_big_stack)
 1082         return ERR_BIG_STACK_DISABLED;
 1083     if (!program_running())
 1084         return ERR_RESTRICTED_OPERATION;
 1085     return push_stack_state(true);
 1086 }
 1087 
 1088 int docmd_depth(arg_struct *arg) {
 1089     vartype *v = new_real(sp + 1);
 1090     if (v == NULL)
 1091         return ERR_INSUFFICIENT_MEMORY;
 1092     return recall_result(v);
 1093 }
 1094 
 1095 int docmd_drop(arg_struct *arg) {
 1096     if (sp == -1)
 1097         return ERR_NONE;
 1098     free_vartype(stack[sp]);
 1099     if (flags.f.big_stack) {
 1100         sp--;
 1101     } else {
 1102         memmove(stack + 1, stack, 3 * sizeof(vartype *));
 1103         stack[REG_T] = new_real(0);
 1104     }
 1105     print_trace();
 1106     return ERR_NONE;
 1107 }
 1108 
 1109 int docmd_dropn(arg_struct *arg) {
 1110     int4 n;
 1111     int err = arg_to_num(arg, &n);
 1112     if (err != ERR_NONE)
 1113         return err;
 1114     if (n > sp + 1)
 1115         return ERR_STACK_DEPTH_ERROR;
 1116     for (int i = sp - n + 1; i <= sp; i++)
 1117         free_vartype(stack[i]);
 1118     if (flags.f.big_stack) {
 1119         sp -= n;
 1120     } else {
 1121         memmove(stack + n, stack, (4 - n) * sizeof(vartype *));
 1122         for (int i = 0; i < n; i++)
 1123             stack[i] = new_real(0);
 1124     }
 1125     print_trace();
 1126     return ERR_NONE;
 1127 }
 1128 
 1129 int docmd_dup(arg_struct *arg) {
 1130     vartype *v = dup_vartype(stack[sp]);
 1131     if (v == NULL)
 1132         return ERR_INSUFFICIENT_MEMORY;
 1133     char prev_stack_lift = flags.f.stack_lift_disable;
 1134     flags.f.stack_lift_disable = 0;
 1135     if (recall_result_silently(v) != ERR_NONE) {
 1136         flags.f.stack_lift_disable = prev_stack_lift;
 1137         return ERR_INSUFFICIENT_MEMORY;
 1138     }
 1139     print_stack_trace();
 1140     return ERR_NONE;
 1141 }
 1142 
 1143 int docmd_dupn(arg_struct *arg) {
 1144     int4 n;
 1145     int err = arg_to_num(arg, &n);
 1146     if (err != ERR_NONE)
 1147         return err;
 1148     if (flags.f.big_stack) {
 1149         if (n > sp + 1)
 1150             return ERR_STACK_DEPTH_ERROR;
 1151         if (!ensure_stack_capacity(n))
 1152             return ERR_INSUFFICIENT_MEMORY;
 1153         for (int i = 1; i <= n; i++) {
 1154             stack[sp + i] = dup_vartype(stack[sp + i - n]);
 1155             if (stack[sp + i] == NULL) {
 1156                 while (--i >= 1)
 1157                     free_vartype(stack[sp + i]);
 1158                 return ERR_INSUFFICIENT_MEMORY;
 1159             }
 1160         }
 1161         sp += n;
 1162     } else {
 1163         switch (n) {
 1164             case 0:
 1165                 break;
 1166             case 1:
 1167                 return docmd_dup(NULL);
 1168             case 2:
 1169                 vartype *v0, *v1;
 1170                 v0 = dup_vartype(stack[REG_X]);
 1171                 if (v0 == NULL)
 1172                     return ERR_INSUFFICIENT_MEMORY;
 1173                 v1 = dup_vartype(stack[REG_Y]);
 1174                 if (v1 == NULL) {
 1175                     free_vartype(v0);
 1176                     return ERR_INSUFFICIENT_MEMORY;
 1177                 }
 1178                 free_vartype(stack[REG_Z]);
 1179                 free_vartype(stack[REG_T]);
 1180                 stack[REG_Z] = v0;
 1181                 stack[REG_T] = v1;
 1182                 break;
 1183             default:
 1184                 return ERR_STACK_DEPTH_ERROR;
 1185         }
 1186     }
 1187     print_stack_trace();
 1188     return ERR_NONE;
 1189 }
 1190 
 1191 int docmd_pick(arg_struct *arg) {
 1192     int4 n;
 1193     int err = arg_to_num(arg, &n);
 1194     if (err != ERR_NONE)
 1195         return err;
 1196     if (n == 0)
 1197         return ERR_NONEXISTENT;
 1198     n--;
 1199     if (n > sp)
 1200         return ERR_STACK_DEPTH_ERROR;
 1201     vartype *v = dup_vartype(stack[sp - n]);
 1202     if (v == NULL)
 1203         return ERR_INSUFFICIENT_MEMORY;
 1204     return recall_result(v);
 1205 }
 1206 
 1207 int docmd_unpick(arg_struct *arg) {
 1208     int4 n;
 1209     int err = arg_to_num(arg, &n);
 1210     if (err != ERR_NONE)
 1211         return err;
 1212     if (n == 0)
 1213         return ERR_NONEXISTENT;
 1214     n--;
 1215     if (n > (flags.f.big_stack ? sp - 1 : sp))
 1216         return ERR_STACK_DEPTH_ERROR;
 1217     // Note: UNPICK consumes X, i.e. drops it from the stack. This is unlike
 1218     // any other STO-like function in Free42, but it is needed in order to make
 1219     // PICK and UNPICK work as a pair like they do in the RPL calculators.
 1220     vartype *v = stack[sp];
 1221     if (flags.f.big_stack) {
 1222         sp--;
 1223     } else {
 1224         vartype *t = dup_vartype(stack[REG_T]);
 1225         if (t == NULL)
 1226             return ERR_INSUFFICIENT_MEMORY;
 1227         memmove(stack + 1, stack, 3 * sizeof(vartype *));
 1228         stack[REG_T] = t;
 1229     }
 1230     free_vartype(stack[sp - n]);
 1231     stack[sp - n] = v;
 1232     print_stack_trace();
 1233     return ERR_NONE;
 1234 }
 1235 
 1236 int docmd_rdnn(arg_struct *arg) {
 1237     int4 n;
 1238     int err = arg_to_num(arg, &n);
 1239     if (err != ERR_NONE)
 1240         return err;
 1241     if (n > sp + 1)
 1242         return ERR_STACK_DEPTH_ERROR;
 1243     if (n > 1) {
 1244         vartype *v = stack[sp];
 1245         memmove(stack + sp - n + 2, stack + sp - n + 1, (n - 1) * sizeof(vartype *));
 1246         stack[sp - n + 1] = v;
 1247     }
 1248     print_trace();
 1249     return ERR_NONE;
 1250 }
 1251 
 1252 int docmd_rupn(arg_struct *arg) {
 1253     int4 n;
 1254     int err = arg_to_num(arg, &n);
 1255     if (err != ERR_NONE)
 1256         return err;
 1257     if (n > sp + 1)
 1258         return ERR_STACK_DEPTH_ERROR;
 1259     if (n > 1) {
 1260         vartype *v = stack[sp - n + 1];
 1261         memmove(stack + sp - n + 1, stack + sp - n + 2, (n - 1) * sizeof(vartype *));
 1262         stack[sp] = v;
 1263     }
 1264     print_trace();
 1265     return ERR_NONE;
 1266 }
 1267 
 1268 ////////////////////
 1269 ///// PGM Menu /////
 1270 ////////////////////
 1271 
 1272 int docmd_pgmmenu(arg_struct *arg) {
 1273     if (!mvar_prgms_exist())
 1274         return ERR_NO_MENU_VARIABLES;
 1275     int err = set_menu_return_err(MENULEVEL_APP, MENU_CATALOG, false);
 1276     if (err == ERR_NONE) {
 1277         set_cat_section(CATSECT_PGM_MENU);
 1278         move_cat_row(0);
 1279     }
 1280     return err;
 1281 }
 1282 
 1283 int docmd_pgmvar(arg_struct *arg) {
 1284     if (!flags.f.printer_enable && program_running())
 1285         return ERR_NONE;
 1286     if (!flags.f.printer_exists)
 1287         return ERR_PRINTING_IS_DISABLED;
 1288 
 1289     int err;
 1290     if (arg->type == ARGTYPE_IND_NUM
 1291             || arg->type == ARGTYPE_IND_STK
 1292             || arg->type == ARGTYPE_IND_STR) {
 1293         err = resolve_ind_arg(arg);
 1294         if (err != ERR_NONE)
 1295             return err;
 1296     }
 1297     if (arg->type != ARGTYPE_STR)
 1298         return ERR_INVALID_TYPE;
 1299 
 1300     int prgm;
 1301     int4 pc;
 1302     if (!find_global_label(arg, &prgm, &pc))
 1303         return ERR_LABEL_NOT_FOUND;
 1304     pc += get_command_length(prgm, pc);
 1305     int saved_prgm = current_prgm;
 1306     current_prgm = prgm;
 1307     bool found = false;
 1308 
 1309     while (true) {
 1310         int command;
 1311         arg_struct arg2;
 1312         get_next_command(&pc, &command, &arg2, 0, NULL);
 1313         if (command != CMD_MVAR)
 1314             break;
 1315         if (!found) {
 1316             shell_annunciators(-1, -1, 1, -1, -1, -1);
 1317             print_text(NULL, 0, true);
 1318             found = true;
 1319         }
 1320 
 1321         vartype *v = recall_var(arg2.val.text, arg2.length);
 1322         char lbuf[32], rbuf[100];
 1323         int llen = 0, rlen = 0;
 1324         string2buf(lbuf, 8, &llen, arg2.val.text, arg2.length);
 1325         char2buf(lbuf, 8, &llen, '=');
 1326 
 1327         if (v == NULL) {
 1328             print_wide(lbuf, llen, "<Unset>", 7);
 1329         } else if (v->type == TYPE_STRING) {
 1330             vartype_string *s = (vartype_string *) v;
 1331             char *sbuf = (char *) malloc(s->length + 2);
 1332             if (sbuf == NULL) {
 1333                 print_wide(lbuf, llen, "<Low Mem>", 9);
 1334             } else {
 1335                 sbuf[0] = '"';
 1336                 memcpy(sbuf + 1, s->txt(), s->length);
 1337                 sbuf[s->length + 1] = '"';
 1338                 print_wide(lbuf, llen, sbuf, s->length + 2);
 1339                 free(sbuf);
 1340             }
 1341         } else {
 1342             rlen = vartype2string(v, rbuf, 100);
 1343             print_wide(lbuf, llen, rbuf, rlen);
 1344         }
 1345     }
 1346     current_prgm = saved_prgm;
 1347     if (found)
 1348         shell_annunciators(-1, -1, 0, -1, -1, -1);
 1349     else
 1350         return ERR_NO_MENU_VARIABLES;
 1351     return ERR_NONE;
 1352 }
 1353 
 1354 ////////////////////////////////////
 1355 ///// Generalized Comparisons //////
 1356 ////////////////////////////////////
 1357 
 1358 struct temp_vartype {
 1359     vartype *v;
 1360     int err;
 1361     temp_vartype(arg_struct *arg, bool require_real) {
 1362         v = NULL;
 1363         err = generic_rcl(arg, &v);
 1364         if (err == ERR_NONE && require_real) {
 1365             if (v->type == TYPE_STRING)
 1366                 err = ERR_ALPHA_DATA_IS_INVALID;
 1367             else if (v->type != TYPE_REAL)
 1368                 err = ERR_INVALID_TYPE;
 1369         }
 1370     }
 1371     ~temp_vartype() {
 1372         free_vartype(v);
 1373     }
 1374 };
 1375 
 1376 int docmd_x_eq_nn(arg_struct *arg) {
 1377     temp_vartype tv(arg, false);
 1378     if (tv.err != ERR_NONE)
 1379         return tv.err;
 1380     return vartype_equals(stack[sp], tv.v) ? ERR_YES : ERR_NO;
 1381 }
 1382 
 1383 int docmd_x_ne_nn(arg_struct *arg) {
 1384     temp_vartype tv(arg, false);
 1385     if (tv.err != ERR_NONE)
 1386         return tv.err;
 1387     return vartype_equals(stack[sp], tv.v) ? ERR_NO : ERR_YES;
 1388 }
 1389 
 1390 int docmd_x_lt_nn(arg_struct *arg) {
 1391     temp_vartype tv(arg, true);
 1392     if (tv.err != ERR_NONE)
 1393         return tv.err;
 1394     return ((vartype_real *) stack[sp])->x < ((vartype_real *) tv.v)->x ? ERR_YES : ERR_NO;
 1395 }
 1396 
 1397 int docmd_x_gt_nn(arg_struct *arg) {
 1398     temp_vartype tv(arg, true);
 1399     if (tv.err != ERR_NONE)
 1400         return tv.err;
 1401     return ((vartype_real *) stack[sp])->x > ((vartype_real *) tv.v)->x ? ERR_YES : ERR_NO;
 1402 }
 1403 
 1404 int docmd_x_le_nn(arg_struct *arg) {
 1405     temp_vartype tv(arg, true);
 1406     if (tv.err != ERR_NONE)
 1407         return tv.err;
 1408     return ((vartype_real *) stack[sp])->x <= ((vartype_real *) tv.v)->x ? ERR_YES : ERR_NO;
 1409 }
 1410 
 1411 int docmd_x_ge_nn(arg_struct *arg) {
 1412     temp_vartype tv(arg, true);
 1413     if (tv.err != ERR_NONE)
 1414         return tv.err;
 1415     return ((vartype_real *) stack[sp])->x >= ((vartype_real *) tv.v)->x ? ERR_YES : ERR_NO;
 1416 }
 1417 
 1418 int docmd_0_eq_nn(arg_struct *arg) {
 1419     temp_vartype tv(arg, true);
 1420     if (tv.err != ERR_NONE)
 1421         return tv.err;
 1422     return ((vartype_real *) tv.v)->x == 0 ? ERR_YES : ERR_NO;
 1423 }
 1424 
 1425 int docmd_0_ne_nn(arg_struct *arg) {
 1426     temp_vartype tv(arg, true);
 1427     if (tv.err != ERR_NONE)
 1428         return tv.err;
 1429     return ((vartype_real *) tv.v)->x != 0 ? ERR_YES : ERR_NO;
 1430 }
 1431 
 1432 int docmd_0_lt_nn(arg_struct *arg) {
 1433     temp_vartype tv(arg, true);
 1434     if (tv.err != ERR_NONE)
 1435         return tv.err;
 1436     return ((vartype_real *) tv.v)->x > 0 ? ERR_YES : ERR_NO;
 1437 }
 1438 
 1439 int docmd_0_gt_nn(arg_struct *arg) {
 1440     temp_vartype tv(arg, true);
 1441     if (tv.err != ERR_NONE)
 1442         return tv.err;
 1443     return ((vartype_real *) tv.v)->x < 0 ? ERR_YES : ERR_NO;
 1444 }
 1445 
 1446 int docmd_0_le_nn(arg_struct *arg) {
 1447     temp_vartype tv(arg, true);
 1448     if (tv.err != ERR_NONE)
 1449         return tv.err;
 1450     return ((vartype_real *) tv.v)->x >= 0 ? ERR_YES : ERR_NO;
 1451 }
 1452 
 1453 int docmd_0_ge_nn(arg_struct *arg) {
 1454     temp_vartype tv(arg, true);
 1455     if (tv.err != ERR_NONE)
 1456         return tv.err;
 1457     return ((vartype_real *) tv.v)->x <= 0 ? ERR_YES : ERR_NO;
 1458 }
 1459 
 1460 ///////////////////////////////////
 1461 ///// String & List Functions /////
 1462 ///////////////////////////////////
 1463 
 1464 int docmd_xstr(arg_struct *arg) {
 1465     if (arg->type != ARGTYPE_XSTR)
 1466         return ERR_INTERNAL_ERROR;
 1467     vartype *v = new_string(arg->val.xstr, arg->length);
 1468     if (v == NULL)
 1469         return ERR_INSUFFICIENT_MEMORY;
 1470     return recall_result(v);
 1471 }
 1472 
 1473 static int concat(bool extend) {
 1474     if (stack[sp - 1]->type == TYPE_STRING) {
 1475         char *text;
 1476         int len;
 1477         char buf[44];
 1478         int templen;
 1479         if (stack[sp]->type == TYPE_STRING) {
 1480             vartype_string *s = (vartype_string *) stack[sp];
 1481             text = s->txt();
 1482             len = s->length;
 1483         } else {
 1484             memcpy(buf, reg_alpha, reg_alpha_length);
 1485             templen = reg_alpha_length;
 1486             reg_alpha_length = 0;
 1487             arg_struct arg;
 1488             arg.type = ARGTYPE_STK;
 1489             arg.val.stk = 'X';
 1490             docmd_arcl(&arg);
 1491             text = reg_alpha;
 1492             len = reg_alpha_length;
 1493         }
 1494         vartype_string *s = (vartype_string *) stack[sp - 1];
 1495         vartype *v = new_string(NULL, s->length + len);
 1496         if (v != NULL) {
 1497             vartype_string *s2 = (vartype_string *) v;
 1498             memcpy(s2->txt(), s->txt(), s->length);
 1499             memcpy(s2->txt() + s->length, text, len);
 1500         }
 1501         if (text == reg_alpha) {
 1502             memcpy(reg_alpha, buf, templen);
 1503             reg_alpha_length = templen;
 1504         }
 1505         if (v == NULL)
 1506             return ERR_INSUFFICIENT_MEMORY;
 1507         return binary_result(v);
 1508     } else if (stack[sp - 1]->type == TYPE_LIST) {
 1509         vartype *v = dup_vartype(stack[sp]);
 1510         if (v == NULL)
 1511             return ERR_INSUFFICIENT_MEMORY;
 1512         vartype_list *list = (vartype_list *) stack[sp - 1];
 1513         if (!disentangle((vartype *) list)) {
 1514             nomem:
 1515             free_vartype(v);
 1516             return ERR_INSUFFICIENT_MEMORY;
 1517         }
 1518         if (extend && v->type == TYPE_LIST) {
 1519             if (!disentangle(v))
 1520                 goto nomem;
 1521             vartype_list *list2 = (vartype_list *) v;
 1522             if (list2->size > 0) {
 1523                 vartype **new_data = (vartype **) realloc(list->array->data, (list->size + list2->size) * sizeof(vartype *));
 1524                 if (new_data == NULL)
 1525                     goto nomem;
 1526                 list->array->data = new_data;
 1527                 // Call binary_result() before doing the actual data transfer.
 1528                 // The reason is that binary_result() can fail, because of the
 1529                 // T duplication, and we don't want to have to roll back all this.
 1530                 stack[sp - 1] = NULL;
 1531                 int err = binary_result((vartype *) list);
 1532                 if (err != ERR_NONE) {
 1533                     // Try to shrink the data array back down. No worries if this
 1534                     // fails, we just hold on to the resized one in that case.
 1535                     new_data = (vartype **) realloc(list->array->data, list->size * sizeof(vartype *));
 1536                     if (new_data != NULL || list->size == 0)
 1537                         list->array->data = new_data;
 1538                     stack[sp - 1] = (vartype *) list;
 1539                     goto nomem;
 1540                 }
 1541                 memcpy(list->array->data + list->size, list2->array->data, list2->size * sizeof(vartype *));
 1542                 list->size += list2->size;
 1543                 // At this point we're done with list2. Since it's a disentangled
 1544                 // copy, the refcount is 1 and it is going to be completely deleted.
 1545                 // We're doing it manually rather than through free_vartype(), so
 1546                 // we don't have to zero out the data array first.
 1547                 free(list2->array->data);
 1548                 free(list2->array);
 1549                 free(list2);
 1550             } else {
 1551                 // Joining an empty list to the list in Y. This is not quite a
 1552                 // no-op, since the binary_result() causes T duplication, which
 1553                 // can fail.
 1554                 stack[sp - 1] = NULL;
 1555                 int err = binary_result((vartype *) list);
 1556                 if (err != ERR_NONE) {
 1557                     stack[sp - 1] = (vartype *) list;
 1558                     goto nomem;
 1559                 }
 1560                 free_vartype(v);
 1561             }
 1562             return ERR_NONE;
 1563         }
 1564         vartype **new_data = (vartype **) realloc(list->array->data, (list->size + 1) * sizeof(vartype *));
 1565         if (new_data == NULL)
 1566             goto nomem;
 1567         list->array->data = new_data;
 1568         // Call binary_result() before doing the actual data transfer.
 1569         // The reason is that binary_result() can fail, because of the
 1570         // T duplication, and we don't want to have to roll back all this.
 1571         stack[sp - 1] = NULL;
 1572         int err = binary_result((vartype *) list);
 1573         if (err != ERR_NONE) {
 1574             // Unlike the 'extend' case, we don't try to shrink the data array
 1575             // back down here. We're only wasting the space of one pointer,
 1576             // so, *shrug*.
 1577             stack[sp - 1] = (vartype *) list;
 1578             goto nomem;
 1579         }
 1580         list->array->data[list->size++] = v;
 1581         // Not freeing v because it is now owned by the target list.
 1582         return ERR_NONE;
 1583     } else {
 1584         return ERR_INVALID_TYPE;
 1585     }
 1586 }
 1587 
 1588 int docmd_append(arg_struct *arg) {
 1589     // APPEND: adds the object in X to the string or list in Y and returns the
 1590     // combined string or list. If Y is a string, the contents of X will be converted
 1591     // to a string in the same way as ARCL. If Y is a list, X will be added to it
 1592     // unchanged. If X is a list, it will be added to Y as one element.
 1593     return concat(false);
 1594 }
 1595 
 1596 int docmd_extend(arg_struct *arg) {
 1597     // EXTEND: adds the object in X to the string or list in Y and returns the
 1598     // combined string or list. If Y is a string, the contents of X will be converted
 1599     // to a string in the same way as ARCL. If Y is a list, X will be added to it
 1600     // unchanged. If X is a list, it will be added to Y element by element.
 1601     return concat(true);
 1602 }
 1603 
 1604 int docmd_substr(arg_struct *arg) {
 1605     // SUBSTR: from the string or list in Z, gets the substring/sublist starting at
 1606     // index Y and ending at index X. If X and/or Y are negative, they are counts from
 1607     // the end, rather than the beginning. The very end of the string or list can be
 1608     // specified by leaving off the 'end' parameter, i.e. by having the string or list
 1609     // in Y and the starting index in X.
 1610     if (sp + 1 < 2)
 1611         return ERR_TOO_FEW_ARGUMENTS;
 1612     vartype *s, *b, *e;
 1613     if (stack[sp - 1]->type == TYPE_STRING || stack[sp - 1]->type == TYPE_LIST) {
 1614         s = stack[sp - 1];
 1615         b = stack[sp];
 1616         e = NULL;
 1617     } else {
 1618         if (sp + 1 < 3)
 1619             return ERR_TOO_FEW_ARGUMENTS;
 1620         s = stack[sp - 2];
 1621         b = stack[sp - 1];
 1622         e = stack[sp];
 1623         if (s->type != TYPE_STRING && s->type != TYPE_LIST)
 1624             return ERR_INVALID_TYPE;
 1625     }
 1626     if (b->type != TYPE_REAL || e != NULL && e->type != TYPE_REAL)
 1627         return ERR_INVALID_TYPE;
 1628     phloat bp = ((vartype_real *) b)->x;
 1629     if (bp <= -2147483648.0 || bp >= 2147483648.0)
 1630         return ERR_INVALID_DATA;
 1631     int4 begin = to_int4(bp);
 1632     phloat ep;
 1633     int4 end;
 1634     if (e != NULL) {
 1635         ep = ((vartype_real *) e)->x;
 1636         if (bp <= -2147483648.0 || bp >= 2147483648.0)
 1637             return ERR_INVALID_DATA;
 1638         end = to_int4(ep);
 1639     }
 1640     int4 len = s->type == TYPE_STRING ? ((vartype_string *) s)->length
 1641                 : ((vartype_list *) s)->size;
 1642     if (begin < 0)
 1643         begin += len;
 1644     if (e == NULL)
 1645         end = len;
 1646     else if (end < 0)
 1647         end += len;
 1648     if (begin < 0 || begin > end || end > len)
 1649         return ERR_INVALID_DATA;
 1650     int4 newlen = end - begin;
 1651     vartype *v;
 1652     if (newlen == len) {
 1653         v = dup_vartype(s);
 1654         if (v == NULL)
 1655             return ERR_INSUFFICIENT_MEMORY;
 1656     } else if (s->type == TYPE_STRING) {
 1657         vartype_string *str = (vartype_string *) s;
 1658         char *text = str->txt();
 1659         v = new_string(text + begin, newlen);
 1660         if (v == NULL)
 1661             return ERR_INSUFFICIENT_MEMORY;
 1662     } else {
 1663         vartype_list *list = (vartype_list *) s;
 1664         vartype_list *r = (vartype_list *) new_list(newlen);
 1665         if (r == NULL)
 1666             return ERR_INSUFFICIENT_MEMORY;
 1667         for (int i = 0; i < newlen; i++) {
 1668             r->array->data[i] = dup_vartype(list->array->data[begin + i]);
 1669             if (r->array->data[i] == NULL) {
 1670                 free_vartype((vartype *) r);
 1671                 return ERR_INSUFFICIENT_MEMORY;
 1672             }
 1673         }
 1674         v = (vartype *) r;
 1675     }
 1676     if (e == NULL)
 1677         return binary_result(v);
 1678     else
 1679         return ternary_result(v);
 1680 }
 1681 
 1682 int docmd_length(arg_struct *arg) {
 1683     // LENGTH: returns the length of the string or list in X.
 1684     int4 len;
 1685     if (stack[sp]->type == TYPE_STRING)
 1686         len = ((vartype_string *) stack[sp])->length;
 1687     else
 1688         len = ((vartype_list *) stack[sp])->size;
 1689     vartype *v = new_real(len);
 1690     if (v == NULL)
 1691         return ERR_INSUFFICIENT_MEMORY;
 1692     unary_result(v);
 1693     return ERR_NONE;
 1694 }
 1695 
 1696 int docmd_head(arg_struct *arg) {
 1697     // HEAD <param>: removes and returns the first character or element from the
 1698     // string or list named by <param>. If the string or list is empty, skip the next
 1699     // instruction.
 1700     int err;
 1701     if (arg->type == ARGTYPE_IND_NUM
 1702             || arg->type == ARGTYPE_IND_STK
 1703             || arg->type == ARGTYPE_IND_STR) {
 1704         err = resolve_ind_arg(arg);
 1705         if (err != ERR_NONE)
 1706             return err;
 1707     }
 1708     if (!ensure_stack_capacity(1))
 1709         return ERR_INSUFFICIENT_MEMORY;
 1710     vartype *s, *v;
 1711     switch (arg->type) {
 1712         case ARGTYPE_NUM: {
 1713             vartype *regs = recall_var("REGS", 4);
 1714             if (regs == NULL)
 1715                 return ERR_SIZE_ERROR;
 1716             if (regs->type != TYPE_REALMATRIX)
 1717                 return ERR_INVALID_TYPE;
 1718             vartype_realmatrix *rm = (vartype_realmatrix *) regs;
 1719             int4 sz = rm->rows * rm->columns;
 1720             int4 n = arg->val.num;
 1721             if (n >= sz)
 1722                 return ERR_SIZE_ERROR;
 1723             if (rm->array->is_string[n] == 0)
 1724                 return ERR_INVALID_TYPE;
 1725             char *text;
 1726             int len;
 1727             get_matrix_string(rm, n, &text, &len);
 1728             if (len == 0)
 1729                 return ERR_NO;
 1730             if (!disentangle(regs))
 1731                 return ERR_INSUFFICIENT_MEMORY;
 1732             get_matrix_string(rm, n, &text, &len);
 1733             v = new_string(text, 1);
 1734             if (v == NULL)
 1735                 return ERR_INSUFFICIENT_MEMORY;
 1736             if (!put_matrix_string(rm, n, text + 1, len - 1)) {
 1737                 free_vartype(v);
 1738                 return ERR_INSUFFICIENT_MEMORY;
 1739             }
 1740             err = recall_result(v);
 1741             return err == ERR_NONE ? ERR_YES : err;
 1742         }
 1743         case ARGTYPE_STK: {
 1744             int idx;
 1745             switch (arg->val.stk) {
 1746                 case 'X': idx = 0; break;
 1747                 case 'Y': idx = 1; break;
 1748                 case 'Z': idx = 2; break;
 1749                 case 'T': idx = 3; break;
 1750                 case 'L': idx = -1; break;
 1751             }
 1752             if (idx == -1) {
 1753                 s = lastx;
 1754             } else {
 1755                 if (idx > sp)
 1756                     return ERR_NONEXISTENT;
 1757                 s = stack[sp - idx];
 1758             }
 1759             doit:
 1760             if (s->type == TYPE_STRING) {
 1761                 vartype_string *str = (vartype_string *) s;
 1762                 if (str->length == 0)
 1763                     return ERR_NO;
 1764                 v = new_string(str->txt(), 1);
 1765                 if (v == NULL)
 1766                     return ERR_INSUFFICIENT_MEMORY;
 1767                 str->trim1();
 1768                 err = recall_result(v);
 1769                 return err == ERR_NONE ? ERR_YES : err;
 1770             } else if (s->type == TYPE_LIST) {
 1771                 vartype_list *list = (vartype_list *) s;
 1772                 if (list->size == 0)
 1773                     return ERR_NO;
 1774                 if (!disentangle(s))
 1775                     return ERR_INSUFFICIENT_MEMORY;
 1776                 v = list->array->data[0];
 1777                 memmove(list->array->data, list->array->data + 1, --list->size * sizeof(vartype *));
 1778                 err = recall_result(v);
 1779                 return err == ERR_NONE ? ERR_YES : err;
 1780             } else {
 1781                 return ERR_INVALID_TYPE;
 1782             }
 1783         }
 1784         case ARGTYPE_STR: {
 1785             s = recall_var(arg->val.text, arg->length);
 1786             if (s == NULL)
 1787                 return ERR_NONEXISTENT;
 1788             goto doit;
 1789         }
 1790         default:
 1791             return ERR_INTERNAL_ERROR;
 1792     }
 1793 }
 1794 
 1795 int docmd_rev(arg_struct *arg) {
 1796     // REV: reverse the string or list in X
 1797     vartype *v;
 1798     if (stack[sp]->type == TYPE_STRING) {
 1799         vartype_string *src = (vartype_string *) stack[sp];
 1800         int4 len = src->length;
 1801         v = new_string(NULL, len);
 1802         if (v == NULL)
 1803             return ERR_INSUFFICIENT_MEMORY;
 1804         vartype_string *dst = (vartype_string *) v;
 1805         char *s = src->txt();
 1806         char *d = dst->txt() + len - 1;
 1807         while (len-- > 0)
 1808             *d-- = *s++;
 1809     } else {
 1810         vartype_list *src = (vartype_list *) stack[sp];
 1811         int4 len = src->size;
 1812         v = new_list(len);
 1813         if (v == NULL)
 1814             return ERR_INSUFFICIENT_MEMORY;
 1815         vartype_list *dst = (vartype_list *) v;
 1816         vartype **s = src->array->data;
 1817         vartype **d = dst->array->data + len - 1;
 1818         while (len-- > 0) {
 1819             vartype *t = dup_vartype(*s++);
 1820             if (t == NULL) {
 1821                 free_vartype(v);
 1822                 return ERR_INSUFFICIENT_MEMORY;
 1823             }
 1824             *d-- = t;
 1825         }
 1826     }
 1827     unary_result(v);
 1828     return ERR_NONE;
 1829 }
 1830 
 1831 int docmd_pos(arg_struct *arg) {
 1832     // POS: finds the first occurrence of the string or list X in Y. Or with three
 1833     // parameters: find the first occurrence of string or list X in Z, starting the
 1834     // search from position Y.
 1835     int pos, startpos;
 1836     int list_sp;
 1837     bool ternary;
 1838     if (stack[sp - 1]->type == TYPE_REAL) {
 1839         phloat start = ((vartype_real *) stack[sp - 1])->x;
 1840         if (start < -2147483648.0 || start > 2147483648.0) {
 1841             startpos = -2;
 1842         } else {
 1843             startpos = to_int(start);
 1844             if (startpos < 0)
 1845                 startpos = -startpos;
 1846         }
 1847         list_sp = sp - 2;
 1848         ternary = true;
 1849     } else {
 1850         startpos = 0;
 1851         list_sp = sp - 1;
 1852         ternary = false;
 1853     }
 1854     if (stack[list_sp]->type == TYPE_STRING) {
 1855         if (stack[sp]->type != TYPE_STRING && stack[sp]->type != TYPE_REAL)
 1856             return ERR_INVALID_TYPE;
 1857         if (startpos == -2)
 1858             return ERR_INVALID_DATA;
 1859         vartype_string *s = (vartype_string *) stack[list_sp];
 1860         pos = string_pos(s->txt(), s->length, stack[sp], startpos);
 1861         if (pos == -2)
 1862             return ERR_INVALID_DATA;
 1863     } else if (stack[list_sp]->type == TYPE_LIST) {
 1864         if (startpos == -2)
 1865             return ERR_INVALID_DATA;
 1866         vartype_list *list = (vartype_list *) stack[list_sp];
 1867         pos = -1;
 1868         for (int4 i = startpos; i < list->size; i++) {
 1869             if (vartype_equals(list->array->data[i], stack[sp])) {
 1870                 pos = i;
 1871                 break;
 1872             }
 1873         }
 1874     } else {
 1875         return ERR_INVALID_TYPE;
 1876     }
 1877     vartype *v = new_real(pos);
 1878     if (v == NULL)
 1879         return ERR_INSUFFICIENT_MEMORY;
 1880     if (ternary)
 1881         return ternary_result(v);
 1882     else
 1883         return binary_result(v);
 1884 }
 1885 
 1886 int docmd_s_to_n(arg_struct *arg) {
 1887     // S->N: convert string to number, like ANUM
 1888     phloat res;
 1889     vartype_string *s = (vartype_string *) stack[sp];
 1890     if (!anum(s->txt(), s->length, &res))
 1891         return ERR_INVALID_DATA;
 1892     vartype *v = new_real(res);
 1893     if (v == NULL)
 1894         return ERR_INSUFFICIENT_MEMORY;
 1895     unary_result(v);
 1896     return ERR_NONE;
 1897 }
 1898 
 1899 int docmd_n_to_s(arg_struct *arg) {
 1900     // N->S: convert number to string, like ARCL
 1901     vartype *v;
 1902     if (stack[sp]->type == TYPE_STRING) {
 1903         v = dup_vartype(stack[sp]);
 1904     } else {
 1905         char buf[100];
 1906         int bufptr = vartype2string(stack[sp], buf, 100);
 1907         v = new_string(buf, bufptr);
 1908     }
 1909     if (v == NULL)
 1910         return ERR_INSUFFICIENT_MEMORY;
 1911     unary_result(v);
 1912     return ERR_NONE;
 1913 }
 1914 
 1915 int docmd_c_to_n(arg_struct *arg) {
 1916     // C->N: convert character to number, like ATOX
 1917     vartype_string *s = (vartype_string *) stack[sp];
 1918     int n;
 1919     if (s->length == 0)
 1920         n = 0;
 1921     else
 1922         n = (unsigned char) s->txt()[0];
 1923     vartype *v = new_real(n);
 1924     if (v == NULL)
 1925         return ERR_INSUFFICIENT_MEMORY;
 1926     unary_result(v);
 1927     return ERR_NONE;
 1928 }
 1929 
 1930 int docmd_n_to_c(arg_struct *arg) {
 1931     // N->C: convert number to character, like XTOA
 1932     phloat n = ((vartype_real *) stack[sp])->x;
 1933     if (n < 0)
 1934         n = -n;
 1935     if (n >= 256)
 1936         return ERR_INVALID_DATA;
 1937     vartype_string *s = (vartype_string *) new_string(NULL, 1);
 1938     if (s == NULL)
 1939         return ERR_INSUFFICIENT_MEMORY;
 1940     s->txt()[0] = to_int(n);
 1941     unary_result((vartype *) s);
 1942     return ERR_NONE;
 1943 }
 1944 
 1945 int docmd_list_t(arg_struct *arg) {
 1946     return stack[sp]->type == TYPE_LIST ? ERR_YES : ERR_NO;
 1947 }
 1948 
 1949 int docmd_newlist(arg_struct *arg) {
 1950     vartype *v = new_list(0);
 1951     if (v == NULL)
 1952         return ERR_INSUFFICIENT_MEMORY;
 1953     return recall_result(v);
 1954 }
 1955 
 1956 int docmd_newstr(arg_struct *arg) {
 1957     vartype *v = new_string("", 0);
 1958     if (v == NULL)
 1959         return ERR_INSUFFICIENT_MEMORY;
 1960     return recall_result(v);
 1961 }
 1962 
 1963 int docmd_to_list(arg_struct *arg) {
 1964     phloat x = ((vartype_real *) stack[sp])->x;
 1965     if (x < 0)
 1966         x = -x;
 1967     if (x >= 2147483648.0)
 1968         return ERR_STACK_DEPTH_ERROR;
 1969     int4 n = to_int4(x);
 1970     if (n > sp)
 1971         return ERR_STACK_DEPTH_ERROR;
 1972     vartype_list *list = (vartype_list *) new_list(n);
 1973     if (list == NULL)
 1974         return ERR_INSUFFICIENT_MEMORY;
 1975     if (flags.f.big_stack) {
 1976         for (int i = 0; i < n; i++)
 1977             list->array->data[i] = stack[sp - n + i];
 1978         free_vartype(lastx);
 1979         lastx = stack[sp];
 1980         sp -= n;
 1981     } else {
 1982         vartype *zeroes[3];
 1983         for (int i = 0; i < n; i++) {
 1984             zeroes[i] = new_real(0);
 1985             if (zeroes[i] == NULL) {
 1986                 while (i > 0)
 1987                     free_vartype(zeroes[--i]);
 1988                 free_vartype((vartype *) list);
 1989                 return ERR_INSUFFICIENT_MEMORY;
 1990             }
 1991         }
 1992         for (int i = 0; i < n; i++)
 1993             list->array->data[i] = stack[sp - n + i];
 1994         free_vartype(lastx);
 1995         lastx = stack[3];
 1996         for (int i = 3; i >= 0; i--) {
 1997             int j = i - n;
 1998             stack[i] = j >= 0 ? stack[j] : zeroes[i];
 1999         }
 2000     }
 2001     stack[sp] = (vartype *) list;
 2002     return ERR_NONE;
 2003 }
 2004 
 2005 int docmd_from_list(arg_struct *arg) {
 2006     vartype_list *list = (vartype_list *) stack[sp];
 2007     int4 n = list->size;
 2008     if (!flags.f.big_stack && n > 3)
 2009         return ERR_STACK_DEPTH_ERROR;
 2010 
 2011     // It would be nice if we could just put the list items
 2012     // on the stack, and then shallow-delete the list, but
 2013     // alas, there's LASTx. So, we start by creating a deep
 2014     // clone.
 2015     list = (vartype_list *) dup_vartype((vartype *) list);
 2016     vartype *size = new_real(n);
 2017     if (list == NULL || size == NULL || !disentangle((vartype *) list)) {
 2018         nomem:
 2019         free_vartype((vartype *) list);
 2020         free_vartype(size);
 2021         return ERR_INSUFFICIENT_MEMORY;
 2022     }
 2023 
 2024     if (flags.f.big_stack) {
 2025         if (!ensure_stack_capacity(n))
 2026             goto nomem;
 2027         free_vartype(lastx);
 2028         lastx = stack[sp];
 2029         for (int i = 0; i < n; i++)
 2030             stack[sp++] = list->array->data[i];
 2031         stack[sp] = size;
 2032     } else {
 2033         free_vartype(lastx);
 2034         lastx = stack[3];
 2035         if (n > 0) {
 2036             for (int i = 0; i < 3; i++) {
 2037                 int j = i - n;
 2038                 if (j < 0)
 2039                     free_vartype(stack[i]);
 2040                 else
 2041                     stack[j] = stack[i];
 2042             }
 2043             for (int i = 0; i < n; i++)
 2044                 stack[3 - n + i] = list->array->data[i];
 2045         }
 2046         stack[3] = size;
 2047     }
 2048     free(list->array->data);
 2049     free(list->array);
 2050     free(list);
 2051     return ERR_NONE;
 2052 }
 2053 
 2054 int docmd_width(arg_struct *arg) {
 2055     vartype *v = new_real(131);
 2056     if (v == NULL)
 2057         return ERR_INSUFFICIENT_MEMORY;
 2058     return recall_result(v);
 2059 }
 2060 
 2061 int docmd_height(arg_struct *arg) {
 2062     vartype *v = new_real(16);
 2063     if (v == NULL)
 2064         return ERR_INSUFFICIENT_MEMORY;
 2065     return recall_result(v);
 2066 }