Free42: common/core_commands7.cc

"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 }